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
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