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

Question

I have a spreadsheet like so called slave:

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

I also have another spreadsheet exactly the same but called master.

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   

I am trying to copy to receivings and the allocated units from the slave workbook over to the master workbook where the ID, Delivery Date and Case Size matches.

Here's what i've tried so far:

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

Nothing seems to happen apart from the workook opening. Nothing is copied over and no error is given. Please can someone show me where i am going wrong? Thanks

Answer 1

you could use AutoFilter() method, like follows:

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