填充，將多個過濾器複製並粘貼到多個工作表中

Question

我想請求您幫助我編寫我的宏。我試圖在這個網站上尋找解決方案，但我找不到任何東西。

我在Workbook_（當前月份）中有9個不同的工作表 - 例如Workbook_July.xls，我必須從報表中以9個不同的標準複製數據（「report_（當前月份）.xls」），名稱不同每個月。工作表名稱：「1」「2」「3」「4」「5」「6」「7」「8」「9」。 （Workbook_（current month））

單元格A8中的自動篩選條件：「EN> 1」，「EN> 2」，「EN> 3」，「EN> 4」，「EN> 5」，EN> 6 「，EN> 7」，「EN> 8」，「EN> 9」（report_（當前月份）.xls）

我需要做的是過濾報表中的整個表格（列A：N ）並從A8中選擇標準。然後我需要從A9中選擇數據：J9 和 N9直到最後一行。表中的第一行總是相同的，但是最後一行的數量總是不同的。我知道我可以使用.End(xlDown)函數，但我不知道如何同時爲A9：J9和N9執行此操作。

當我選擇範圍後，我需要複製數據，然後將數據從標準「EN> 1」粘貼到工作表「1」，從「EN> 2」到工作表「2」，直到最後一個標準「EN> 9 」。 Workbook_（當前月份）中的工作表名稱始終相同。

我寫的作品非常好1個工作表宏，但我要爲所有9個工作表做到這一點（請注意，有工作簿中的多個工作表）：

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 

其中最重要的事情是我每天都更新Workbook_（當前月份），並且需要在包含內容的最後一行之後複製數據，即使它是重複的。因此，如果星期一的最後一行是71，那麼週二我需要開始將數據從報表複製到Workbook。請注意，我想開始複製A3行中的數據（第1行和第2行包含標題和公式）

提前致謝。

Answer 1

我寫了一個非常好用的宏，但是我仍然在努力處理1件事情。在每個月的開始我的跟蹤器是空的，當我複製數據的時間時，我得到了一個運行時錯誤1004「應用程序定義或對象定義」行「copyRange.SpecialCells（xlCellTypeVisible）.Copy tgt。範圍（「B3」）。完（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) 

是否有任何其他代碼比這copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B3").End(xlDown).Offset(1)，將開始在每個工作簿，並且如果從粘貼複製範圍在細胞B3中的數據有是單元格中的任何文本，然後轉到第一個空單元格並將數據粘貼到那裏？

最好的問候，