VBA宏-根據參考表上的值復制粘貼多個工作表

Question

我有多個工作表：

1) Agent Sales
Name | Product | Sales
A | XX | $100
B | XX | $200
C | YY | $150
A | YY | $400


2) Agent Expense
Name | Product | Expense
A | XX | $10
B | XX | $20
C | YY | $15
A | YY | $80

這個想法是在每個代理商的單獨工作表上創建一個報告，將它們與每個產品的其他代理商進行比較。 例如，對於代理A：

>     Sales
>     Name | Product | Sales
>     A | XX | $100
>     B | XX | $200
>     
>     Expense
>     Name | Product | Sales
>     A | XX | $10
>     B | XX | $10
>     
>     
>     Sales
>     Name | Product | Sales
>     A | YY | $400
>     C | YY | $150
>     
>     Expense
>     Name | Product | Sales
>     A | YY | $80
>     C | YY | $15

我只是想學習VBA，而解決該問題的第一步是讓復制和粘貼功能使用自動過濾功能。 到目前為止，這是我的代碼：Sub Test（）

Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sales")
ws.Rows(1).AutoFilter Field:=1, Criteria1:="A"
ws.Rows(1).AutoFilter Field:=2, Criteria1:="XX"
ws.Range("A2:C2", Range("A2:C2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Sheet2").Range("A1").PasteSpecial

Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Expense")
ws2.Rows(1).AutoFilter Field:=1, Criteria1:="A"
ws2.Rows(1).AutoFilter Field:=2, Criteria1:="XX"
ws2.Range("A2:C2", Range("A2:C2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Sheet2").Range("H1").PasteSpecial

End Sub

它返回了運行時錯誤1004-對象范圍的方法失敗。

但是，如果我僅復制粘貼銷售表，則代碼有效。

我看到了VBA可能會刪除剪貼板上數據的帖子，但是鑒於成功粘貼了銷售表，我不確定為什么第二個錯誤。

感謝所有幫助/想法。

Answer 1

在您的以下代碼行中：

ws2.Range("A2:C2", Range("A2:C2").End(xlDown)).Copy

Range缺少Sheet參考，您需要添加ws2 ，如下所示：

ws2.Range("A2:C2", ws2.Range("A2:C2").End(xlDown)).Copy

復制下面的完整代碼，不會出現任何錯誤（在您的PC上使用您上傳的示例數據進行了測試）

Sub TestCopyPaste()

Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sales")

ws.Rows(1).AutoFilter Field:=1, Criteria1:="A"
ws.Rows(1).AutoFilter Field:=2, Criteria1:="XX"
ws.Range("A2:C2", ws.Range("A2:C2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Sheet2").Range("A1").PasteSpecial

Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Expense")

ws2.Rows(1).AutoFilter Field:=1, Criteria1:="A"
ws2.Rows(1).AutoFilter Field:=2, Criteria1:="XX"
ws2.Range("A2:C2", ws2.Range("A2:C2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Sheet2").Range("H1").PasteSpecial

End Sub

Answer 2

我注釋掉了Field:=1過濾器，因為您試圖按產品而不是名稱和產品分組。

Sub TestCopyPaste()
    Dim NextRow As Long, x As Long
    Dim Name As String, Product As String
    Dim dict As Object

    Set dict = CreateObject("Scripting.Dictionary")

    Dim ExpenseRange As Range

    Worksheets("Report").Cells.Clear

    For x = 2 To Worksheets("Sales").Range("A" & Rows.Count).End(xlUp).Row
        Name = Worksheets("Sales").Cells(x, 1)
        Product = Worksheets("Sales").Cells(x, 2)

        If Not dict.Exists(Product) Then
            NextRow = Worksheets("Report").Range("A" & Rows.Count).End(xlUp).Row
            If NextRow > 1 Then NextRow = NextRow + 2

            getFilteredData(Worksheets("Sales"), Name, Product).Copy Worksheets("Report").Cells(NextRow, 1)

            Set ExpenseRange = getFilteredData(Worksheets("Expense"), Name, Product)

            If Not ExpenseRange Is Nothing Then
                NextRow = Worksheets("Report").Range("A" & Rows.Count).End(xlUp).Row + 2
                ExpenseRange.Copy Worksheets("Report").Cells(NextRow, 1)
            End If

            dict.Add Product, vbNullString
        End If
    Next

    Worksheets("Report").Columns.AutoFit

End Sub

Function getFilteredData(ws As Worksheet, Name As String, Product As String)
     With ws
        '.Rows(1).AutoFilter Field:=1, Criteria1:=Name
        .Rows(1).AutoFilter Field:=2, Criteria1:=Product
        Set getFilteredData = .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
    End With
End Function