VBA to Copy data from multiple workbook to a master sheet

Hi,

Does any one help me to get a vba code that meets the below mentioned requirements,

I want to copy certain rows from different workbook to a master copy, but the criteria for the selection of row from the work books is based on the date entered on the left most cell of the rows . and all work books follow the uniform structure. It would be great if I could enter a date in the input box and then the macro copy the rows with that particular date in the left most column. Please find below the snapshot of the work book that needs to be copied.

Date	        work type 1	work type 2	work type 3	work type 4	work type 5
14-Jan-15	     14	             15	              16	             14	            14
15-Jan-15	      36	             37	               45	              32	            11

I got a vba code that partially fills my requirement. But that requires manually editing of the range in the macro code. Seems a message box to enter either the the range or the date , and the macro runs based on the inputs will fulfill my requirement.

Sub Import_to_Master()
    Dim sFolder As String
    Dim sFile As String
    Dim wbD As Workbook, wbS As Workbook
     
    Application.ScreenUpdating = False
    Set wbS = ThisWorkbook
    sFolder = wbS.Path & "\"
     
    sFile = Dir(sFolder)
    Do While sFile <> ""
         
        If sFile <> wbS.Name Then
            Set wbD = Workbooks.Open(sFolder & sFile) 'open the file; add condition to
             
             ' >>>>>> Adapt this part
            wbD.Sheets("Sheet1").Range("A3:H3").Copy
            wbS.Activate
            Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
             ' >>>>>>
            wbD.Close savechanges:=True 'close without saving
        End If
         
        sFile = Dir 'next file
    Loop
    Application.ScreenUpdating = True
End Sub

Thanking you in advance,

Regards,

Lijith

So when the macro runs, you're really wanting to pull a single row from each of the workbooks, the one that matches the given date?

Does the pile of workbooks you're accessing ever change? Or is it a static set of workbooks? The reason I ask is because if it's always the same then you might be able to get the results you want with a simple set of lookup formulas referencing those closed workbooks. No VBA needed in that case.

Ok, so we're going to run through 80 random workbooks in a folder, open each one and search for ONE row with a particular date? Or would it be multiple rows?

Exactly, what you said is correct, We need to copy single raw from 80 different workbooks to a master sheet. I need to copy only single raw from each sheeet but it should fill my condition I provided through input box.( either it is with the date or with the range( A3:H3 on one day and A4:H4 on next day) etc. ).

See if the following modification works for you.....

The below code will prompt you to input a date in Input Box and then check the column A in Sheet1 of all the destination workbooks and if found, it copies the row to the Master workbook.

Sub Import_to_Master()
    Dim sFolder As String
    Dim sFile As String
    Dim wbD As Workbook, wbS As Workbook
    Dim wsD As Worksheet
    Dim myDate As Variant, r As Long
         
    Application.ScreenUpdating = False
    Set wbS = ThisWorkbook
    sFolder = wbS.Path & "\"
     
    sFile = Dir(sFolder)
    Do Until IsDate(myDate) = True
    myDate = InputBox("Enter A Date (DD/MM/YYYY).")
    If Not IsDate(myDate) Then
        MsgBox "You have entered an invalid Date. Please try again.....", vbExclamation, "Invalid Date"
    End If
    Loop
    myDate = CDbl(CDate(myDate))
    Do While sFile <> ""
        If sFile <> wbS.Name Then
            Set wbD = Workbooks.Open(sFolder & sFile) 'open the file; add condition to
            Set wsD = wbD.Sheets("Sheet1")
            If WorksheetFunction.CountIf(wsD.Columns(1), myDate) > 0 Then
                 ' >>>>>> Adapt this part
                 r = Application.Match(myDate, wsD.Range("A:A"), 0)
                wsD.Range("A" & r & ":H" & r).Copy
                wbS.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                 ' >>>>>>
             End If
            wbD.Close savechanges:=True 'close without saving
        End If
        sFile = Dir 'next file
    Loop
    Application.ScreenUpdating = True
End Sub

You're welcome.

If that takes care of your original question, please mark your thread as Solved by selecting Thread Tools (just above your first post) --> Mark thread as solved.