filtter, copy and paste multiple filters to multiple worksheets

Question

I would like to ask you for help with my macro that I want to write. I tried to look for solution on this website but I couldn't find anything.

I have 9 diferent worksheets in Workbook_(current month)- for instance Workbook_July.xls where I have to copy data with 9 different criteria from the report ("report_(current month).xls") ,the name is different every month.

Worksheet names: "1", "2", "3", "4", "5", "6", "7", "8", "9". (Workbook_(current month))

Autofilter criteria in cell A8: "EN > 1", "EN > 2", "EN > 3", "EN > 4", "EN > 5", EN > 6", EN > 7", "EN > 8", "EN > 9" (report_(current month).xls)

What I need to do is to filter the whole table in the report (columns A:N) and select criteria from A8. Then I need to select data from A9:J9 and N9 till the last row. The first row in the table is always the same however the number of end row is always different. I know what I can use .End(xlDown) function but I don't know how to do this simutaneously for A9:J9 and N9.

After I select the range I need to copy and then paste the data from criteria "EN > 1" to worksheet "1", from "EN > 2" to worksheet "2" till the last criteria "EN > 9". The name of worksheets in Workbook_(current month) are always the same.

I wrote a macro that works pretty well on 1 worksheet but I want to do this for all 9 worksheets (please note that there are more worksheets in the workbook):

Sub copyandpaste1()

Application.ScreenUpdating = False

ActiveWorkbook.Sheets("1").Activate

yourPath = "C:\Users\" & Environ("username") & "\Desktop\test\VTR tracker\"
file = Dir(yourPath & "Report*.xls")
Do While file <> vbNullString
Workbooks.Open (yourPath & file)
file = Dir()
Loop

Rows("8:8").Select
Selection.AutoFilter
ActiveSheet.Range("$A$8:$N$50000").AutoFilter Field:=1, Criteria1:= _
    "EN > 1"

With Worksheets("Report*").AutoFilter.Range
Range("B" & .Offset(2, 9).SpecialCells(xlCellTypeVisible)(9).Row).Select
End With

Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 8)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

For Each wb In Application.Workbooks
If wb.Name Like "Workbook*" Then
    wb.Activate
End If
Next wb
Worksheets("1").Activate
lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
    xlNone, SkipBlanks:=False, Transpose:=False

Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 8)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

For Each wb In Application.Workbooks
If wb.Name Like "Workbook*" Then
    wb.Activate
End If
Next wb
Worksheets("1").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:= _
    xlNone, SkipBlanks:=False, Transpose:=False
Range("A4").Select
Application.CutCopyMode = False

Application.ScreenUpdating = False

For Each w In Workbooks
If w.Name Like "*Report*" Then
Windows(w.Name).Activate
Exit For
End If
Next w

With Worksheets("Report").AutoFilter.Range
Range("B" & .Offset(14, 9).SpecialCells(xlCellTypeVisible)(9).Row).Select
End With

Range(ActiveCell.Offset(0, 12), ActiveCell.Offset(0, 12)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

For Each wb In Application.Workbooks
If wb.Name Like "Viator_Translation_Tracker_*" Then
    wb.Activate
End If
Next wb
Worksheets("1").Activate
lMaxRows = Cells(Rows.Count, "N").End(xlUp).Row
Range("N" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
    xlNone, SkipBlanks:=False, Transpose:=False

End Sub

One of the most important thing is that I update Workbook_(current month) every day and the data needs to be copied after the last row with content, even if it is a duplicate. So if the last row on Monday is 71 then on Tuesday I need to start copying data from report to Workbook from 72. Please note that I want to start copying data in row A3 (Rows 1 and 2 contains headers and formulas)

Thanks in advance.

Adrian Adrian · Accepted Answer · 2017-07-26T09:44:24

I wrote a macro that works pretty well however I am still struggling with 1 thing. At the begining of each month my tracker is empty and when I copy the data for the time time I get a Run-Time Error 1004 "Application-defined or Object-defined" in line "copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B3").End(xlDown).Offset(1)"

Dim src As Worksheet
Dim tgt As Worksheet
Dim filterRange As Range
Dim filterRange2 As Range
Dim filterRange3 As Range
Dim filterRange4 As Range
Dim copyRange As Range
Dim lastRow As Long
Dim tgt2 As Worksheet
Set src = ThisWorkbook.Sheets("report")
Set tgt = ThisWorkbook.Sheets("1")
Set tgt2 = ThisWorkbook.Sheets("2")
Set tgt3 = ThisWorkbook.Sheets("3")
Set tgt4 = ThisWorkbook.Sheets("4")
src.AutoFilterMode = False
lastRow = src.Range("B" & src.Rows.Count).End(xlUp).Row
Set filterRange = src.Range("A8:J" & lastRow)
Set copyRange = src.Range("B9:J" & lastRow)
filterRange.AutoFilter Field:=1, Criteria1:="EN-GB > 1"
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B3").End(xlDown).Offset(1)
Set filterRange2 = src.Range("A8:J" & lastRow)
filterRange2.AutoFilter Field:=1, Criteria1:="EN-GB > 2"
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt2.Range("B3").End(xlDown).Offset(1)
Set filterRange3 = src.Range("A8:J" & lastRow)
filterRange3.AutoFilter Field:=1, Criteria1:="EN-GB > 3"
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt3.Range("B3").End(xlDown).Offset(1)
Set filterRange4 = src.Range("A8:J" & lastRow)
filterRange4.AutoFilter Field:=1, Criteria1:="EN-GB > 4"
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt4.Range("B3").End(xlDown).Offset(1)

Is there any other code than this copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B3").End(xlDown).Offset(1) that will start pasting the data from copy range in cell B3 in each workbook and if there is any text in the cell then go to the first empty cell and paste the data there?

Best Regards,

filtter, copy and paste multiple filters to multiple worksheets

1 Answers