Conditional Copying

**Ivor** · 01-09-2011, 04:55 PM

A Happy 20011 to one and all.

I was wondering if someone could assist me? I have cheekily copied someone's code to achieve what I want, however it doesn't quite do what I require. Basically I have a spreadsheet which I want only those rows which fall under a certain condition to be copied into a new sheet. For example if I have data populated in columns A, B & C, where C contains number reanging from 1 to 10; I would like to copy all data where the number in column C ranges from 3 and above. The code below copies everything that I need but I have to specify the number I want displayed. Is there a way (for example) I can amend the code to select all numbers greater than 3 and above? currently the code will display only those rows where column C is equal to 0?

I have attached my test spreadsheet for ease of understanding.

Apologies for any confision and thank you all in advance.

Cheers
Ivor

Sub Extract_Data_Two()
Application.ScreenUpdating = False
Dim FilterCriteria
Dim CurrentsheetName As String
Dim NewFileName As String
'Get the current sheets's name
CurrentsheetName = ActiveSheet.Name
'Select the range
'(note you can change this to meet your requirements)
Range("A1:C27").Select
'Apply Autofilter
Selection.AutoFilter
'Get the filter's criteria from the user
FilterCriteria = 2
'Filter the data based on the user's input
'NOTE - this filter is on column N (field:=14), to change
'to a different column you need to change the field number
Selection.AutoFilter field:=3, Criteria1:=FilterCriteria
'Select the visible cells (the filtered data)
Selection.SpecialCells(xlCellTypeVisible).Select
'Copy the cells
Selection.Copy
Sheets.Add
'Make sure you are in cell A1
Range("A1").Select
'Paste the copied cells
ActiveSheet.Paste
'Clear the clipboard contents
Application.CutCopyMode = False
' Auto fits text in Columns
Cells.Select
Selection.Columns.AutoFit
Range("A1").Select
'Go back to the original sheet
Worksheets(CurrentsheetName).Activate
'Clear the autofilter
Selection.AutoFilter field:=1
'Take the Autofilter off
Selection.AutoFilter
'Go to A1
Range("A1").Select
Application.ScreenUpdating = True
End Sub

**mrice** · 01-09-2011, 05:52 PM

Try this which uses a different approach

Option Explicit

Sub ConditionalCopy()
Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim N As Long
Const Min = 3

Set SourceSheet = ActiveSheet
Sheets.Add
Set TargetSheet = ActiveSheet
SourceSheet.Activate
SourceSheet.Rows(1).Copy Destination:=TargetSheet.Rows(1)
For N = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(N, 3) >= Min Then
        Rows(N).Copy Destination:=TargetSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If
Next N
End Sub

**Ivor** · 01-09-2011, 06:02 PM

Good evening Martin (MRice)

Well all I can say is WOW. You have not only solved my issue but simplified the code for me. This will make it easier for me to replicate this on many other sheets even if they have more columns to filter.

Thank you so much as you have just made my Mondasy morning back in the office a lot less stressful.

Thank you again sir

Enjoy the rest of your Sunday

Cheers
Ivor

**Ivor** · 01-12-2011, 01:48 PM

Originally Posted by mrice

Try this which uses a different approach

Option Explicit

Sub ConditionalCopy()
Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim N As Long
Const Min = 3

Set SourceSheet = ActiveSheet
Sheets.Add
Set TargetSheet = ActiveSheet
SourceSheet.Activate
SourceSheet.Rows(1).Copy Destination:=TargetSheet.Rows(1)
For N = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(N, 3) >= Min Then
        Rows(N).Copy Destination:=TargetSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If
Next N
End Sub

Hello Martin

Hope you have managed to find this message.

Ok hopefully I won't confuse you with my ignorance, and I must pre warn you that I have taken the long way around modifying your code, as I am a complete novice.

The attached spreadhseet contains the data I require modifying. Basically, in 6 individual columns (E,J,P,U,AA & AF,) I have the numbers ranging from 1 to 12 (which relates to the data in the rows to the left of the numbers). When I place a '3' in your code and run it, a new sheet is created listing the data that I want (i.e. showing everything from 3 and upwards.....to 12); I do not require the columns titled "Hub Status Code" to appear in the new sheet, so I modified your code to only capture the columns that I need (A to D, F to I .....so on). However whilst this works very well the data looks awfully messy and has a lot of gaps.

Therefore what I am trying to do (painfully) is to make the first attachment (Stats) look like the second attachment (Stats result). I am almost there but am having to use multiple macros on each new sheet to get what I want.

I hope this makes sense and I apologise for refering you to two different sheets, just that this is the easiest way to explain what I want without too much waffle. I have also copied below my modification to your code.

Thanks again sir

Hopefully speak soon

Cheers
Ivor

Sub ConditionalCopy()

Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim N As Long
Const Min = 3

Set SourceSheet = ActiveSheet
Sheets.Add
Set TargetSheet = ActiveSheet
SourceSheet.Activate
SourceSheet.Rows(1).Copy Destination:=TargetSheet.Rows(1)
For N = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(N, 5) >= Min Then
       Range(Cells(N, 1), Cells(N, 4)).Copy Destination:=TargetSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
       End If
       
    If Cells(N, 10) >= Min Then
       Range(Cells(N, 6), Cells(N, 9)).Copy Destination:=TargetSheet.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0)
       End If
       
    If Cells(N, 16) >= Min Then
       Range(Cells(N, 12), Cells(N, 15)).Copy Destination:=TargetSheet.Cells(Rows.Count, 12).End(xlUp).Offset(1, 0)
       End If
       
    If Cells(N, 21) >= Min Then
       Range(Cells(N, 17), Cells(N, 20)).Copy Destination:=TargetSheet.Cells(Rows.Count, 17).End(xlUp).Offset(1, 0)
       End If
       
    If Cells(N, 27) >= Min Then
       Range(Cells(N, 23), Cells(N, 26)).Copy Destination:=TargetSheet.Cells(Rows.Count, 23).End(xlUp).Offset(1, 0)
       End If
       
    If Cells(N, 32) >= Min Then
       Range(Cells(N, 28), Cells(N, 31)).Copy Destination:=TargetSheet.Cells(Rows.Count, 28).End(xlUp).Offset(1, 0)
       End If
   Next N
End Sub

**mrice** · 01-12-2011, 05:22 PM

The examples helped a lot.

Can you try the following...

Sub ConditionalCopy()

Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim N As Long
Const Min = 3

Set SourceSheet = ActiveSheet
Sheets.Add
Set TargetSheet = ActiveSheet
SourceSheet.Activate
SourceSheet.Rows("2:3").Copy Destination:=TargetSheet.Rows(1)
For N = 4 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(N, 5) >= Min And Cells(N, 5) <> "" Then
       Range(Cells(N, 1), Cells(N, 4)).Copy Destination:=TargetSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If
Next N
       
For N = 4 To Cells(Rows.Count, 6).End(xlUp).Row
    If Cells(N, 10) >= Min And Cells(N, 10) <> "" Then
       Range(Cells(N, 6), Cells(N, 9)).Copy Destination:=TargetSheet.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0)
    End If
Next N
       
For N = 4 To Cells(Rows.Count, 12).End(xlUp).Row
    If Cells(N, 16) >= Min And Cells(N, 16) <> "" Then
       Range(Cells(N, 12), Cells(N, 15)).Copy Destination:=TargetSheet.Cells(Rows.Count, 12).End(xlUp).Offset(1, 0)
    End If
Next N

For N = 4 To Cells(Rows.Count, 17).End(xlUp).Row
    If Cells(N, 21) >= Min And Cells(N, 21) <> "" Then
       Range(Cells(N, 17), Cells(N, 20)).Copy Destination:=TargetSheet.Cells(Rows.Count, 17).End(xlUp).Offset(1, 0)
    End If
Next N
     
For N = 4 To Cells(Rows.Count, 23).End(xlUp).Row
    If Cells(N, 27) >= Min And Cells(N, 27) <> "" Then
       Range(Cells(N, 23), Cells(N, 26)).Copy Destination:=TargetSheet.Cells(Rows.Count, 23).End(xlUp).Offset(1, 0)
    End If
Next N

For N = 4 To Cells(Rows.Count, 28).End(xlUp).Row
    If Cells(N, 32) >= Min And Cells(N, 32) <> "" Then
       Range(Cells(N, 28), Cells(N, 31)).Copy Destination:=TargetSheet.Cells(Rows.Count, 28).End(xlUp).Offset(1, 0)
    End If
Next N
End Sub

**Ivor** · 01-13-2011, 11:48 AM

Originally Posted by mrice

The examples helped a lot.

Can you try the following...

Sub ConditionalCopy()

Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim N As Long
Const Min = 3

Set SourceSheet = ActiveSheet
Sheets.Add
Set TargetSheet = ActiveSheet
SourceSheet.Activate
SourceSheet.Rows("2:3").Copy Destination:=TargetSheet.Rows(1)
For N = 4 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(N, 5) >= Min And Cells(N, 5) <> "" Then
       Range(Cells(N, 1), Cells(N, 4)).Copy Destination:=TargetSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If
Next N
       
For N = 4 To Cells(Rows.Count, 6).End(xlUp).Row
    If Cells(N, 10) >= Min And Cells(N, 10) <> "" Then
       Range(Cells(N, 6), Cells(N, 9)).Copy Destination:=TargetSheet.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0)
    End If
Next N
       
For N = 4 To Cells(Rows.Count, 12).End(xlUp).Row
    If Cells(N, 16) >= Min And Cells(N, 16) <> "" Then
       Range(Cells(N, 12), Cells(N, 15)).Copy Destination:=TargetSheet.Cells(Rows.Count, 12).End(xlUp).Offset(1, 0)
    End If
Next N

For N = 4 To Cells(Rows.Count, 17).End(xlUp).Row
    If Cells(N, 21) >= Min And Cells(N, 21) <> "" Then
       Range(Cells(N, 17), Cells(N, 20)).Copy Destination:=TargetSheet.Cells(Rows.Count, 17).End(xlUp).Offset(1, 0)
    End If
Next N
     
For N = 4 To Cells(Rows.Count, 23).End(xlUp).Row
    If Cells(N, 27) >= Min And Cells(N, 27) <> "" Then
       Range(Cells(N, 23), Cells(N, 26)).Copy Destination:=TargetSheet.Cells(Rows.Count, 23).End(xlUp).Offset(1, 0)
    End If
Next N

For N = 4 To Cells(Rows.Count, 28).End(xlUp).Row
    If Cells(N, 32) >= Min And Cells(N, 32) <> "" Then
       Range(Cells(N, 28), Cells(N, 31)).Copy Destination:=TargetSheet.Cells(Rows.Count, 28).End(xlUp).Offset(1, 0)
    End If
Next N
End Sub

Hello Martin

nothing more I can say except of how grateful I am for your help. Your new code does exactly what I require, apart from formatting the final result into a pretty page as the source data but I have created a additional macro to deal with that which works perfectly.

I have a couple of issues to work on next with the sheet, but I can deal with those in a new post/thread as I have already utilised all of my free help from your good self.

I have given a small donation to your Marathon run, and wish you all of the best with that....I know four other people who have entered and I wish I could join them...but for the fact that I am not very good at running ha ha ha.

Anyway thank you again for your help and maybe our paths will cross on the forum again (maybe in a day or two with my new thread

)

Take it easy

Cheers
Ivor