PDA

View Full Version : [SOLVED] Copy matching data from many workbooks to summary workbook



msquared99
06-25-2015, 11:09 AM
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
06-25-2015, 03:04 PM
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
06-26-2015, 12:51 PM
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
06-26-2015, 03:42 PM
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
06-30-2015, 06:06 AM
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
06-30-2015, 06:49 AM
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
06-30-2015, 08:20 AM
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!