VBA：查找文件并将单元格值从一个工作簿中的列复制到另一个根据条件？

Question

我有一个像所谓的奴隶的电子表格：

Id    Delivery Date    Case Size   Receivings    Allocated 
1     12/12/2016       4           100           100
2     13/12/2016       5           200           50
3     11/10/2016       6           200           25
4     15/11/2014       3           90            10

我还有另一个完全相同的电子表格，但称为主数据表。

Id    Delivery Date    Case Size   Receivings    Allocated 
1     12/12/2016       4                     
2     13/12/2016       5                      
3     11/10/2016       6                      
4     15/11/2014       3   

我正在尝试从从工作簿复制到接收和分配的单位，再复制到ID，交货日期和案例大小匹配的主工作簿。

到目前为止，这是我尝试过的：

Sub GetTheName()
    Dim s As String, FileName As String

    s = "C:\Users\Mark O'Brien\Documents\*.xlsm"

    FileName = Dir(s)

    Do Until FileName = ""
        If FileName Like "Food Specials Rolling Depot Memo*" Then MsgBox FileName


        'Start Merge of Memo


Dim Dic As Object, key As Variant, oCell As Range, i&
    Dim w1 As Worksheet, w2 As Worksheet

    Set Dic = CreateObject("Scripting.Dictionary")
    Set w1 = Workbooks.Open(FileName).Sheets(1)
    Set w2 = ThisWorkbook.Sheets(1)

    i = w1.Cells.SpecialCells(xlCellTypeLastCell).Row

    For Each oCell In w1.Range("R10:R" & i)
        If Not Dic.exists(oCell.Value) Then
            Dic.Add oCell.Value, oCell.Offset(, -3).Value
        End If
    Next

    i = w2.Cells.SpecialCells(xlCellTypeLastCell).Row

    For Each oCell In w2.Range("F10:F" & i)
        For Each key In Dic
            If oCell.Value = key Then
                oCell.Offset(, 2).Value = Dic(key)
            End If
        Next
    Next

        'End Merge of Memo




        FileName = Dir()
        ActiveSheet.Range("A8").Value = Now()
    Loop


End Sub

除了工作钩的开口，似乎什么都没有发生。 不会复制任何内容，也不会给出错误。 请有人能告诉我我要去哪里错吗？ 谢谢

Answer 1

您可以使用AutoFilter()方法，如下所示：

Option Explicit

Sub main()
    Dim cell As Range, masterRng As Range

    With Sheets("MasterSheet") '<--| reference your "Master" sheet (change "MasterSheet" to your actual "Master" sheet name)
        Set masterRng = .Range("A2", .Cells(.Rows.count, 1).End(xlUp)) '<--| reference its columns A cells from row 2 down to last not empty row
    End With

    With Sheets("SlaveSheet") '<--| reference your "Slave" sheet (change "SlaveSheet" to your actual "Slave" sheet name)
        With .Range("C1", .Cells(.Rows.count, 1).End(xlUp)) '<--| reference its columns A and B range from row 1 (headers) down to column A last not empty row
            For Each cell In masterRng  '<--| loop through "Master" sheet column A "ID"
                .AutoFilter field:=1, Criteria1:=cell.Value '<--| filter referenced range on its 2nd column (i.e. column B) with current cell 1 column offset  value (i.e. current "Master" sheet "ID")
                .AutoFilter field:=3, Criteria1:=cell.Offset(, 2).Value '<--| filter referenced range on its 3rd column (i.e. column C) with current cell 2 columns offset value (i.e. current "Master" sheet "Case Size")
                If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any cell filtered other than headers
                    cell.Offset(, 3).Resize(, 2).Value = .Resize(.Rows.count - 1, 1).Offset(1, 3).SpecialCells(xlCellTypeVisible).Cells(1, 1).Resize(, 2).Value '<--|write first filtered 3rd column cell value in current cell offset 2 columns value (i.e. current "Master" sheet "Names")
                End If
            Next cell
        End With
        .AutoFilterMode = False
    End With
End Sub