Copy matching data from many workbooks to summary workbook

[msquared99]

I already have this partially solved. The code works but copies weird data from the workbooks. I need some help refining the code. I have many workbooks in a folder which the code loops through. In each workbook Column A has a date and the range from cell A24 through column I is variable. There is data with dates under the range I am looking at. So the range I want is say A24:I37, the other range which I do not care about is say in A41:I65 which contains a date as well. Here is what I am trying to do:

1. Loop through each workbook in the folder.
2. When a matching date is found in column A in the range beginning A24:I to LastRow, copy only the matching data in column A, G, and I to the summary workbook. So, if the match was found in say row 30 then copy only cells A30, G30, and I30. Also, place the name of the workbook that had the matching data in the summary workbook. If the workbook opened does not have a match then do nothing.

Here is the code:

Sub MergeAllWorkbooks()
    'Posted for help in VBAX
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim NRow As Long, LastRow As Long
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim DestRange As Range, FindRange As Range, i As Range, SourceRange As Range
    Dim FindVal As Date
    
    
    FindVal = Application.InputBox("Please enter a date as MM/DD/YYYY.", "Macro Canceled")
        If FindVal = False Then
            MsgBox "Macro was cancelled.", 64, "Cancel was clicked."
            Exit Sub
        End If
        
    ' Create a new workbook and set a variable to the first sheet.
    Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:\Testing\Test Files\"
    
    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 1
    
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName = Dir(FolderPath & "*.xl*")
    
    ' Loop until Dir returns an empty string.
    Do While FileName <> ""
        ' Open a workbook in the folder
        Set WorkBk = Workbooks.Open(FolderPath & FileName)
        LastRow = WorkBk.Worksheets(1).Range("A24").End(xlDown).Row
        
        ' Set the cell in column A to be the file name.
        SummarySheet.Range("A" & NRow).Value = FileName
        
        ' Set the source range to be A24 through I & LastRow.
        Set SourceRange = WorkBk.Worksheets(1).Range("A24:I" & LastRow)
        
       
        ' Set the destination range to start at column B and
        ' be the same size as the source range.
        Set DestRange = SummarySheet.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
           
        ' Copy over the values from the source to the destination.
         For Each i In SourceRange
            If i.Value = FindVal Then
                DestRange.Cells(NRow, 2).Value = SourceRange.Cells(i.Row, 1).Value
                DestRange.Cells(NRow, 3).Value = SourceRange.Cells(i.Row, 7).Value
                DestRange.Cells(NRow, 4).Value = SourceRange.Cells(i.Row, 9).Value
            End If
            Next
                
        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
        
        ' Use Dir to get the next file name.
        FileName = Dir()
        LastRow = Empty
    Loop
    
    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    SummarySheet.Columns.AutoFit
End Sub

[SamT]

All the changes I made are in this part

         ' Set the destination range 
        Set DestRange = SummarySheet 'Doesn't need to be as deep and wide as the SourceRange
         
         ' Copy over the values from the source to the destination.
        For Each i In SourceRange.Columns(1) 'Only looking for dates in Column A
            If i.Value = FindVal Then
                DestRange.Cells(NRow, 2).Value = SourceRange.Cells(i.Row, 1).Value
                DestRange.Cells(NRow, 3).Value = SourceRange.Cells(i.Row, 7).Value
                DestRange.Cells(NRow, 4).Value = SourceRange.Cells(i.Row, 9).Value
               ' Increase NRow so that we know where to copy data next.
                NRow = NRow + 1
          End If
        Next

If you want the files name on every Row, then

        For Each i In SourceRange.Columns(1) 'Only looking for dates in Column A
            If i.Value = FindVal Then
               With DestRange
                  .Cells(NRow, 1) = FileName
                  .Cells(NRow, 2).Value = SourceRange.Cells(i.Row, 1).Value
                  .Cells(NRow, 3).Value = SourceRange.Cells(i.Row, 7).Value
                  .Cells(NRow, 4).Value = SourceRange.Cells(i.Row, 9).Value
               End With
               ' Increase NRow so that we know where to copy data next.
                NRow = NRow + 1
            End If

[msquared99]

Thanks for the reply Sam.

I think I have found my issue but do not know how to solve it.
The below line of code sets the range I want to search for the date. In the code below the range in say DataBook1 is A24:I32, the SourceRange returns data from row 54 which is well out of the set SourceRange and the date does not even match.

Set SourceRange = WorkBk.Worksheets(1).Range("A24:I" & LastRow)

So, in this code here:

DestRange.Cells(NRow, 2).Value = SourceRange.Cells(i.Row, 1).Value

Is the .Cells(i.Row,1) somehow adding more rows to the SourceRange?

[SamT]

If you don't see a grey bar on the left hand side of the code page, use the Tools Menu >> Options >> Editor format Tab and check the "Margin Indicator Bar" box.

To set a BreakPoint to stop the code there, click in the Margin Indicator Bar next to the line of code you want it to stop at. When the code is stopped, you can hover the mouse over a variable and see the value of that variable at that time.

Set a Break point at the X=, and Step thru the loop by pressing F8. Note the Dim X and also Watch X'es Value(s.)

 Dim X
X = SourceRange.Address
X = FindVal
For Each i In SourceRange 
X = i.Address
X = i.Value
            If i.Value = FindVal Then 
                DestRange.Cells(NRow, 2).Value = SourceRange.Cells(i.Row, 1).Value 
                DestRange.Cells(NRow, 3).Value = SourceRange.Cells(i.Row, 7).Value 
                DestRange.Cells(NRow, 4).Value = SourceRange.Cells(i.Row, 9).Value 
            End If 
        Next

When you are satisfied with the code, delete every line with an X.

[msquared99]

Good morning Sam.

I ran the code like you suggested. All the ranges show up as they should. I also watched them in the Immediate window.

There are 6 workbooks in the folder I am using. 3 of them has a match to the control date I am using, 11/15/2015.

Here is what the macro is doing:

Match book1:
Search Range - A24:I33
Return row is 52 with the date 6/1/2015

Match book2:
Search Range - A24:I34
Return row is 56 with the date 8/1/2012

Match book3:
Search Range - A24:I35
Return row 50 with a date 3/1/15

Would there be a better option to find the date and copy the data?

Thanks!

[SamT]

Here's a code snippet you can look at that is a bit faster. You still have to open each book in the FileNameArray individually.

   '''' Put all the file names in the path in Array
    FileNameArray = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir " & _
    FolderPath & "*.xl* v /b /s").stdout.readall, vbCrLf), ".")

[msquared99]

I figured it out.

I changed this:

DestRange.Cells(NRow, 2).Value = SourceRange.Cells(i.Row, 1).Value

To this:

DestRange.Cells(NRow, 2).Value = SourceRange.Cells(i.Row - 24 + 1, 1).Value

Now it is working fine.

Thanks Sam!