Copy Cells to another Worksheet Based on Multi Criteria

**cambralenta** · 07-06-2013, 05:26 PM

I read this thread that almost as the code that i need.

Sub Macro2()
 
Dim ws As Worksheet
 
Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name <> "Data" Then
        With Sheets("Data")
            .Range("A1").AutoFilter field:=7, Criteria1:=ws.Name
            .AutoFilter.Range.Offset(1).Copy ws.Range("A2")
            .ShowAllData
        End With
    End If
Next ws

Sheets("Data").AutoFilterMode = False

Application.ScreenUpdating = True
    
End Sub

As the original author i want to paste only column A to E (without the field criteria column).
Please, someone can point me to changes that i have to make!?
Thanks in advance,
Luís

**tehneXus** · 07-06-2013, 07:15 PM

Hi,

please check the attached sample which contains test data from the other thread you mentioned and adapted code to copy only columns A-E: CopyToSeparateSheetsWithCondition.xls
if you need to change the number of columns again do this in "Resize(, 5)" where 5 is the number of columns starting at A

code:

Option Explicit

Sub CopyToSheets()
    Dim xlWs As Worksheet
     
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Worksheets("Data")
        For Each xlWs In ThisWorkbook.Worksheets
            If xlWs.Name <> .Name Then
                .Range("A1").AutoFilter Field:=7, Criteria1:=xlWs.Name
                .AutoFilter.Range.Offset(1).Resize(, 5).SpecialCells(12).Copy xlWs.Range("A2")
                .ShowAllData
            End If
        Next xlWs
        .AutoFilterMode = False
    End With
    
    Application.ScreenUpdating = True
End Sub

**cambralenta** · 07-06-2013, 07:42 PM

Hi tehneXus,

Just now i saw your reply. Your code works better for me I think.

Thanks

**cambralenta** · 07-06-2013, 07:33 PM

I think I got it!
I´m using this:

 If ws.Name <> "Data" Then
        With Sheets("Data")
            .Range("C5").AutoFilter field:=4, Criteria1:=ws.Name
            .AutoFilter.Range.Offset(1).Columns(1).Copy ws.Range("B5")
            .AutoFilter.Range.Offset(1).Columns(2).Copy ws.Range("C5")
            .AutoFilter.Range.Offset(1).Columns(3).Copy ws.Range("D5")
            .ShowAllData
        End With
    End If

Must test more to see if it works!