Ron's code is more complicated then you probably need because of the
filtering. I left the fil;tering in Ron's code put changed the filter to "*"
to keep everything. I also put the summary data in the workbook where the
macro is located instead of creating a new workbook.
You need to create a worksheet called "Folder sheet" in the same workbook as
the macro. Put the folder names in column a starting in Row 1 with no blank
rows.
The macro creates a new sheet called summary with the merged data. if the
macro fails be sure to delete this sheet before running the macro again.
Sub Basic_Example_4()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim rng As Range, SearchValue As String
Dim FilterField As Integer, RangeAddress As String
Dim ShName As Variant, RwCount As Long
Dim FolderRowCount As Long
'**********************************************************
'***Change this five code lines before you run the macro***
'**********************************************************
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Fill in the sheet name where the data is in each workbook
'Use ShName = "Sheet1" if you want to use a sheet name instead if the
index
'We use the first sheet in every workbook in this example(I use the index)
ShName = 1
'Fill in the filter range: A1 is the header of the first column and G is
'the last column in the range and it will filter on all rows on the sheet
'You can also use a fixed range like A1:G2500 if you want
RangeAddress = Range("A1:G" & Rows.Count).Address
'Field that you want to filter in the range ( 1 = column A in this
'example because the filter range start in column A
FilterField = 1
'Fill in the filter value ("<>ron" if you want the opposite)
'Or use wildcards like "*ron" for cells that start with ron or use
'"*ron*" if you look for cells where ron is a part of the cell value
SearchValue = "*"
'**********************************************************
'**********************************************************
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'create new sheet for summary
With ThisWorkbook
Set BaseWks = .Sheets.Add(after:=.Sheets(.Sheets.Count))
BaseWks.Name = "Summary"
'set row number of summary to 1
rnum = 1
End With
With ThisWorkbook.Sheets("Folder sheet")
FolderRowCount = 1
Do While .Range("A" & FolderRowCount) <> ""
MyPath = .Range("A" & FolderRowCount)
'Add a slash after MyPath if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder go to next folder
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
Else
'Fill the array(myFiles)with the list of Excel files in the
folder
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
'Loop through all files in the array(myFiles)
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
'set filter range
With mybook.Worksheets(ShName)
Set sourceRange = .Range(RangeAddress)
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
'Find the last row in BaseWks
rnum = RDB_Last(1, BaseWks.Cells) + 1
With sourceRange.Parent
Set rng = Nothing
'Firstly, remove the AutoFilter
.AutoFilterMode = False
'Filter the range on the FilterField column
sourceRange.AutoFilter Field:=FilterField, _
Criteria1:=SearchValue
With .AutoFilter.Range
'Check if there are results after you use
AutoFilter
RwCount = .Columns(1).Cells. _
SpecialCells(xlCellTypeVisible).Cells.Count - 1
If RwCount = 0 Then
'There is no data, only the header
Else
' Set a range without the Header row
Set rng = .Resize(.Rows.Count - 1,
.Columns.Count). _
Offset(1,
0).SpecialCells(xlCellTypeVisible)
'Copy the range and the file name in column A
If rnum + RwCount < BaseWks.Rows.Count Then
BaseWks.Cells(rnum,
"A").Resize(RwCount).Value _
= mybook.Name
rng.Copy BaseWks.Cells(rnum, "B")
End If
End If
End With
'Remove the AutoFilter
.AutoFilterMode = False
End With
End If
'Close the workbook without saving
mybook.Close savechanges:=False
End If
'Open the next workbook
Next FNum
'Set the column width in the new workbook
BaseWks.Columns.AutoFit
MsgBox "Look at the merge results in the new " & _
"workbook after you click on OK"
End If
End If
FolderRowCount = FolderRowCount + 1
Loop
End With
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function
Robin said:
hi
could anyone help me modify Ron's codes for "Merge data from all workbooks
in a folder (1)" Example 4
what i need this macro to do is to merge workbooks from different
directories, not from just one folder.
I was adviced [by Joel (thx man!)] that one of the ways to do this would be
to save all the paths for the different workbooks into one workbook, and some
how modify the codes to get the array values from this workbook.
So i was just wondering if anyone could help me with this?
Regards
Robin
