Copy and Past filtered data to specific columns

[craigs23]

Hi All,

I am hoping somenone will be able to help.

what am trying to achieve is, I have code which allowsme to filter raw dat this filtred data is then copied and pasted to a seperate sheet on the next empty row.
The data is always posted starting in column "A" which is fine for customer 1 however what I am trying to do if I change the filter to customer 2 then this dat should be copied to the same sheet as customer 1 but instead of column "A" it should be pasted to column "H".

I have pasted the code I have so far below.

Sub Sample()
  Dim wb1 As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim copyFrom As Range
  Dim lRow As Long
  Dim strSearch As String
  Set wb1 = ThisWorkbook
  Set ws1 = wb1.Worksheets("Sheet3")
  ws1.Activate
  strSearch = "Customer1"
 
  
  With ws1
  
  .AutoFilterMode = False
  lRow = .Range("A" & .Rows.Count).End(xlUp).Row
  With .Range("C1:C" & lRow)
  .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
  
  Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
  End With
  .AutoFilterMode = False
  End With
  
  Set ws2 = wb1.Worksheets("Sheet4")
  
  With ws2
  ws2.Activate
  lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
  
  copyFrom.Copy .Rows(lRow)
  
  End With
On Error Resume Next
  End Sub

Can anyone Help?
Thanks in advance

 

[Luke M]

Try this. Do note that we can no longer copy the entire row if we're pasting to col H (as it no longer fits. )

Sub Sample()
  Dim wb1 As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim copyFrom As Range
  Dim lRow As Long
  Dim strSearch As String
  Dim pasteCol As String
  Set wb1 = ThisWorkbook
  Set ws1 = wb1.Worksheets("Sheet3")
  ws1.Activate
  strSearch = "Customer1"
    Select Case UCase(strSearch)
        Case "CUSTOMER1"
            pasteCol = "A"
        Case "CUSTOMER2"
            pasteCol = "H"
        Case Else
            'Default if not one of the above
            pasteCol = "A"
    End Select
  With ws1
   
    .AutoFilterMode = False
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    With .Range("C1:C" & lRow)
        .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
       
        'How many columns of data do we really need? 100?
        Set copyFrom = .Offset(1, 0).Resize(, 100).SpecialCells(xlCellTypeVisible)
    End With
    .AutoFilterMode = False
  End With
  Set ws2 = wb1.Worksheets("Sheet4")
  With ws2
    .Activate
    lRow = .Cells(Rows.Count, pasteCol).End(xlUp).Offset(1, 0).Row
   
    copyFrom.Copy .Cells(lRow, pasteCol)
  End With

End Sub

 

[craigs23]

Try this. Do note that we can no longer copy the entire row if we're pasting to col H (as it no longer fits. )

Sub Sample()
  Dim wb1 As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim copyFrom As Range
  Dim lRow As Long
  Dim strSearch As String
  Dim pasteCol As String
  Set wb1 = ThisWorkbook
  Set ws1 = wb1.Worksheets("Sheet3")
  ws1.Activate
  strSearch = "Customer1"
    Select Case UCase(strSearch)
        Case "CUSTOMER1"
            pasteCol = "A"
        Case "CUSTOMER2"
            pasteCol = "H"
        Case Else
            'Default if not one of the above
            pasteCol = "A"
    End Select
  With ws1
  
    .AutoFilterMode = False
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    With .Range("C1:C" & lRow)
        .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
      
        'How many columns of data do we really need? 100?
        Set copyFrom = .Offset(1, 0).Resize(, 100).SpecialCells(xlCellTypeVisible)
    End With
    .AutoFilterMode = False
  End With
  Set ws2 = wb1.Worksheets("Sheet4")
  With ws2
    .Activate
    lRow = .Cells(Rows.Count, pasteCol).End(xlUp).Offset(1, 0).Row
  
    copyFrom.Copy .Cells(lRow, pasteCol)
  End With
 
End Sub

Hi Luke,
Thanks for your quick reply, this is very close to what I am trying to achieve however perhaps i should clarify a little.

The raw data to be filtered is across 7 columns, A - G the filter is applied to column C. (i.e customer ID column) your code works but it only copies data from column C - G is there anyway I can amend this to copy A-G?

Thanks in advance

 

[Luke M]

Sure thing.

Sub Sample()
  Dim wb1 As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim copyFrom As Range
  Dim lRow As Long
  Dim strSearch As String
  Dim pasteCol As String
  Set wb1 = ThisWorkbook
  Set ws1 = wb1.Worksheets("Sheet3")
  ws1.Activate
  strSearch = "Customer1"
    Select Case UCase(strSearch)
        Case "CUSTOMER1"
            pasteCol = "A"
        Case "CUSTOMER2"
            pasteCol = "H"
        Case Else
            'Default if not one of the above
           pasteCol = "A"
    End Select
  With ws1
   
    .AutoFilterMode = False
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    With .Range("C1:C" & lRow)
        .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
       
        'Changed this line to only copy columns A:G
       Set copyFrom = ws1.Range("A2:G" & lRow).SpecialCells(xlCellTypeVisible)
    End With
    .AutoFilterMode = False
  End With
  Set ws2 = wb1.Worksheets("Sheet4")
  With ws2
    .Activate
    lRow = .Cells(Rows.Count, pasteCol).End(xlUp).Offset(1, 0).Row
   
    copyFrom.Copy .Cells(lRow, pasteCol)
  End With

End Sub

 

[craigs23]

Hi Luke,
That works perfectly thanks for your time and help.
whilst I have been playing with the code it occured to me that it I would need to have an sub routine for every unique entry (filter result) which is probaly not the most efficent method.
So I was wondering is it possible to loop through the script for each unique entry and then (as per the existing Macro) copy the result and past to a new spread sheet?

Thanks again for your help

 

[Luke M]

Thankfully, someone's already written some code to do just that thing.
http://www.rondebruin.nl/win/s3/win006.htm