Merging from multiple workbooks helps

[alex589]

Hi All,</SPAN>

I would like to receive some help or suggestions on the following code based on what I am trying to do. It is copied from this website -</SPAN>

http://msdn.microsoft.com/en-us/library/cc837974(v=office.12).aspx </SPAN>

The code works perfectly but works a slightly different way that I want to. What it does right now is to merge cells (A2:C15) of every worksheet named "xxx" from all workbooks in a folder to a summary sheet (Sheet2) of an active workbook. The loops work perfectly by the way.</SPAN> </SPAN>

I don't want it to go through every file in the directory and merge the range from every file that meets the criteria above. Here is what I need the code to do. The code only allows to merge files with file names I type into cells A:1:A6 of my active workbook(Sheet1). Let's say I have in cell1 of my worksheet typed "myfile", the code will go out and searches the folder for myfile.xls and copies all cells from A:C15 from worksheet named "xxx". Now, I need the same when I input others file names in my sheet column. The botoom line is that the code will only loop through files based on file names in column A of my current workbook. </SPAN>

Thanks a lot everyone!!!</SPAN>


Private Sub CommandButton1_Click()</SPAN>
Dim MyPath As String, FilesInPath As String</SPAN>
Dim MyFiles() As String</SPAN>
Dim SourceRcount As Long, FNum As Long</SPAN>
Dim mybook As Workbook, BaseWks As Worksheet</SPAN>
Dim sourceRange As Range, destrange As Range</SPAN>
Dim rnum As Long, CalcMode As Long</SPAN>

' Change this to the path\folder location of your files.</SPAN>
MyPath = "</SPAN>C:\Users\Ron\test</SPAN>"</SPAN>

' Add a slash at the end of the path if needed.</SPAN>
If Right(MyPath, 1) <> "\" Then</SPAN>
MyPath = MyPath & "\"</SPAN>
End If</SPAN>

' If there are no Excel files in the folder, exit.</SPAN>
FilesInPath = Dir(MyPath & "*.xls*")</SPAN>
If FilesInPath = "" Then</SPAN>
MsgBox "No files found"</SPAN>
Exit Sub</SPAN>
End If</SPAN>

' Fill the myFiles array with the list of Excel files</SPAN>
' in the search folder.</SPAN>
FNum = 0</SPAN>
Do While FilesInPath <> ""</SPAN>
FNum = FNum + 1</SPAN>
ReDim Preserve MyFiles(1 To FNum)</SPAN>
MyFiles(FNum) = FilesInPath</SPAN>
FilesInPath = Dir()</SPAN>
Loop</SPAN>

' Set various application properties.</SPAN>
With Application</SPAN>
CalcMode = .Calculation</SPAN>
.Calculation = xlCalculationManual</SPAN>
.ScreenUpdating = False</SPAN>
.EnableEvents = False</SPAN>
End With</SPAN>

' Active worksheet.</SPAN>
Set BaseWks = ActiveWorkbook.Worksheets("Sheet2")</SPAN>
rnum = 2</SPAN>

' Loop through all files in the myFiles array.</SPAN>
If FNum > 0 Then</SPAN>
For FNum = LBound(MyFiles) To UBound(MyFiles)</SPAN>
Set mybook = Nothing</SPAN>
On Error Resume Next</SPAN>
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))</SPAN>
On Error GoTo 0</SPAN>

If Not mybook Is Nothing Then</SPAN>
On Error Resume Next</SPAN>

' Change this range to fit your own needs.</SPAN>
With mybook.Worksheets("xxx")</SPAN>
Set sourceRange = .Range("A2:C15")</SPAN>
End With</SPAN>

If Err.Number > 0 Then</SPAN>
Err.Clear</SPAN>
Set sourceRange = Nothing</SPAN>
Else</SPAN>
' If source range uses all columns then</SPAN>
' skip this file.</SPAN>
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then</SPAN>
Set sourceRange = Nothing</SPAN>
End If</SPAN>
End If</SPAN>
On Error GoTo 0</SPAN>

If Not sourceRange Is Nothing Then</SPAN>

SourceRcount = sourceRange.Rows.Count</SPAN>

If rnum + SourceRcount >= BaseWks.Rows.Count Then</SPAN>
MsgBox "There are not enough rows in the target worksheet."</SPAN>
BaseWks.Columns.AutoFit</SPAN>
mybook.Close savechanges:=False</SPAN>
GoTo ExitTheSub</SPAN>
Else</SPAN>



' Set the destination range.</SPAN>
Set destrange = BaseWks.Range("A" & rnum)</SPAN>

' Copy the values from the source range</SPAN>
' to the destination range.</SPAN>
With sourceRange</SPAN>
Set destrange = destrange. _</SPAN>
Resize(.Rows.Count, .Columns.Count)</SPAN>
End With</SPAN>
destrange.Value = sourceRange.Value</SPAN>

rnum = rnum + SourceRcount</SPAN>
End If</SPAN>
End If</SPAN>
mybook.Close savechanges:=False</SPAN>
End If</SPAN>

Next FNum</SPAN>
BaseWks.Columns.AutoFit</SPAN>
End If</SPAN>

ExitTheSub:</SPAN>
' Restore the application properties.</SPAN>
With Application</SPAN>
.ScreenUpdating = True</SPAN>
.EnableEvents = True</SPAN>
.Calculation = CalcMode</SPAN>
End With</SPAN>
End Sub</SPAN>

 

[JLGWhiz]

This is in pieces, but you should be able to fit it into your code. Just read the comments that are entered.

Code:
Dim wks As Worksheet, lstRw As Long, rng As Range '<<<Add to declaration at top of prcedure
Set wks = Sheets(1) '<<<Edit sheet name for ActiveSheet current workbook
lstRw = wks.Cells(Rows.Count, 1).EndI(xlUp).Row '<<<add near beginning of procedure
Set rng = wks.Range("A2:A" & lstRw) '<<<add near beginning of procedure
'<<<<Then modify this part where the files are opened.
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
For Each c In Range
If MyFiles(FNum) = c.Value Then
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
End If
On Error GoTo 0
Code

 

[JLGWhiz]

This is in pieces, but you should be able to fit it into your code. Just read the comments that are entered.

Code:
Dim wks As Worksheet, lstRw As Long, rng As Range '<<<ADD top prcedure
Set wks = Sheets(1) '<<<EDIT workbook
lstRw = wks.Cells(Rows.Count, 1).EndI(xlUp).Row '<<<ADD of procedure
Set rng = wks.Range("A2:A" & lstRw) '<<<ADD of procedure
'<<<<THEN opened.
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
For Each c In Range
If MyFiles(FNum) = c.Value Then
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
End If
On Error GoTo 0
Code

I have to start using the HTML maker. The code gets all garbled up otherwise. This should be more readable.
Using the same code that you have with these modifications:

Code:
Dim wks As Worksheet, lstRw As Long, rng As Range 'Add to declaration at top of prcedure
Set wks = Sheets(1) 'Edit sheet name for ActiveSheet current workbook
lstRw = wks.Cells(Rows.Count, 1).EndI(xlUp).Row 'add near beginning of procedure
Set rng = wks.Range("A2:A" & lstRw) 'add near beginning of procedure
'Then modify this part where the files are opened.
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
For Each c In Range
If MyFiles(FNum) = c.Value Then 'This is an added If Then statement, with End If below
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
End If
Code:

 

[alex589]

Thanks for your help! I edited the code and it returns an error. It says "argument not optional" and highlights the word range in the following code : For Each c In Range

Do you know what to do with it?

The following is the edited code:

Private Sub CommandButton1_Click()
    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 wks As Worksheet, lstRw As Long, rng As Range 'Add to declaration at top of prcedure
    Dim rnum As Long, CalcMode As Long
    ' Change this to the path\folder location of your files.
    MyPath = "C:\\"
    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xls*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
    ' Fill the myFiles array with the list of Excel files
    ' in the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop
    ' Set various application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ' Add a new workbook with one sheet.
    
    'Set BaseWks = ActiveWorkbook.Worksheets("Sheet2")
    Set wks = Sheets("Sheet2") 'Edit sheet name for ActiveSheet current workbook
    rnum = 2
    ' Loop through all files in the myFiles array.
    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))
         
         
lstRw = wks.Cells(Rows.Count, 1).EndI(xlUp).Row 'add near beginning of procedure
Set rng = wks.Range("A2:A" & lstRw) 'add near beginning of procedure
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
For Each c In Range
If MyFiles(FNum) = c.Value Then 'This is an added If Then statement, with End If below
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
End If
                      
            On Error GoTo 0
            If Not mybook Is Nothing Then
                On Error Resume Next
 
                ' Change this range to fit your own needs.
                With mybook.Worksheets("xxx")
                    Set sourceRange = .Range("A2:C15")
                End With
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
                If Not sourceRange Is Nothing Then
                    SourceRcount = sourceRange.Rows.Count
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
                        
                        ' Set the destination range.
                        Set destrange = BaseWks.Range("A" & rnum)
                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
        Next FNum
        BaseWks.Columns.AutoFit
    End If
ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

 

[JLGWhiz]

Thanks for your help! I edited the code and it returns an error. It says "argument not optional" and highlights the word range in the following code : For Each c In Range

Do you know what to do with it?


[/code]

I was really having a bad hair day yesterday, and I don't have that much of it left. Yes, I know what to do with it. Fis the typo by changing "Range" to "rng"

Code:
For Each c In rng
Code:

 

[alex589]

Sorry to hear that! Changed it and now it says "Invalid Next Control Variable Reference"

This is the code:

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 wks As Worksheet, lstRw As Long, rng As Range 'Add to declaration at top of prcedure
Dim rnum As Long, CalcMode As Long
' Change this to the path\folder location of your files.
MyPath = "C:"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xls*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If


' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Add a new workbook with one sheet.

'Set BaseWks = ActiveWorkbook.Worksheets("Sheet2")
Set wks = Sheets("Sheet2") 'Edit sheet name for ActiveSheet current workbook
rnum = 2
' Loop through all files in the myFiles array.
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))


lstRw = wks.Cells(Rows.Count, 1).EndI(xlUp).Row 'add near beginning of procedure
Set rng = wks.Range("A2:A" & lstRw) 'add near beginning of procedure
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
For Each c In rng

If MyFiles(FNum) = c.Value Then 'This is an added If Then statement, with End If below
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
End If

On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next

' Change this range to fit your own needs.
With mybook.Worksheets("xxx")
Set sourceRange = .Range("A2:C15")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

' Set the destination range.
Set destrange = BaseWks.Range("A" & rnum)
' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next FNum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

 

[JLGWhiz]

I guess it was worse than I thought, another omission. Should have a Next after the If ... Then statement.

Code:
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
For Each c In Range
If MyFiles(FNum) = c.Value Then 'This is an added If Then statement, with End If below
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
End If
Next
On Error GoTo 0
Code:

The Next FNum command is further down in the code and that is what it was picking up for the Next c. Which of course did not match, so it errored out. Should work after this fix.

 

[alex589]

I guess it helped a little but now it says "Object doesn't support this property or method".... thanks for helping me!!!

 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 wks As Worksheet, lstRw As Long, rng As Range 'Add to declaration at top of prcedure
    Dim rnum As Long, CalcMode As Long
    ' Change this to the path\folder location of your files.
    MyPath = "C:"
    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xls*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
    
   ' Fill the myFiles array with the list of Excel filesin the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop
    ' Set various application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ' Sheet of active workbook in which cells be merged.
    
    Set BaseWks = ActiveWorkbook.Worksheets("Sheet2")
    rnum = 2
    
    
    ' Loop through all files in the myFiles array.
    If FNum > 0 Then
     
         
Set wks = Sheets("Sheet1") 'Edit sheet name for ActiveSheet current workbook
lstRw = wks.Cells(Rows.Count, 1).EndI(xlUp).Row 'add near beginning of procedure
Set rng = wks.Range("A1:A5" & lstRw) 'add near beginning of procedure
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
For Each c In rng

If MyFiles(FNum) = c.Value Then 'This is an added If Then statement, with End If below
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
End If
Next
                      
            On Error GoTo 0
            If Not mybook Is Nothing Then
                On Error Resume Next
 
                ' Change this range to fit your own needs.
                With mybook.Worksheets("xxx")
                    Set sourceRange = .Range("A2:C15")
                End With
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
                If Not sourceRange Is Nothing Then
                    SourceRcount = sourceRange.Rows.Count
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
                        
                        ' Set the destination range.
                        Set destrange = BaseWks.Range("A" & rnum)
                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
        Next FNum
        BaseWks.Columns.AutoFit
    End If
ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

 

[JLGWhiz]

I guess it helped a little but now it says "Object doesn't support this property or method".... thanks for helping me!!!

[/code]

Which line of code is highlighted for that error message. I suspect that it might be the If statement because I do not see that c was declared in the Dim statements as a range. So add this to your Dim Statements at the top:

Code:
Dim c As Range
Code:

 

[alex589]

It didn't highlight anything. Now it says "Next without if" and highlights the "Next" in "Next FNum"

I don't know why it doesn't work. Do you have any ideas?

Private Sub CommandButton1_Click()

    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 wks As Worksheet, lstRw As Long, rng As Range 'Add to declaration at top of prcedure
    Dim rnum As Long, CalcMode As Long
    Dim c As Range

    ' Change this to the path\folder location of your files.
        MyPath = "C:"

    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xls*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
   
   ' Fill the myFiles array with the list of Excel filesin the search folder.
       FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    ' Set various application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' Sheet of active workbook in which cells be merged.
    
    Set BaseWks = ActiveWorkbook.Worksheets("Sheet2")
    rnum = 2
    
    ' Loop through all files in the myFiles array.
    If FNum > 0 Then
     
Set wks = Sheets("Sheet1") 'Edit sheet name for ActiveSheet current workbook
lstRw = wks.Cells(Rows.Count, 1).EndI(xlUp).Row 'add near beginning of procedure
Set rng = wks.Range("A1:A5" & lstRw) 'add near beginning of procedure For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
For Each c In rng
           
If MyFiles(FNum) = c.Value Then 'This is an added If Then statement, with End If below
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
End If
Next
                      
            On Error GoTo 0
            If Not mybook Is Nothing Then
                On Error Resume Next
                ' Change this range to fit your own needs.
                With mybook.Worksheets("xxx")
                    Set sourceRange = .Range("A1:C5")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else

                    ' If source range uses all columns then skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
                If Not sourceRange Is Nothing Then
                    SourceRcount = sourceRange.Rows.Count
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        ' Set the destination range.
                        Set destrange = BaseWks.Range("A" & rnum)
                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
        Next FNum
        BaseWks.Columns.AutoFit
    End If
ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub