Combine Multiple Workbooks

[jammer12001]

I am trying to combine multiple workbooks together. I have some code that works great except I only want it to combine one sheet from each workbook. The workbooks are identical they just hold different data. Each book contains 8 worksheets and I want to copy only data from "Container Info"

Option Explicit
 
Sub CombineSheetsFromAllFilesInADirectory()
     
    Dim Path            As String 
    Dim FileName        As String
    Dim tWB             As Workbook
    Dim tWS             As Worksheet 
    Dim mWB             As Workbook 
    Dim aWS             As Worksheet 
    Dim RowCount        As Long
    Dim uRange          As Range

    Path = "C:\" 
     
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 
    Set mWB = Workbooks.Add(1) 
    Set aWS = mWB.ActiveSheet 

    If Right(Path, 1) <> Application.PathSeparator Then 
        Path = Path & Application.PathSeparator 
    End If
    FileName = DIR(Path & "*.xls", vbNormal)
    Do Until FileName = "" 
        If Path <> ThisWorkbook.Path Or FileName <> ThisWorkbook.Name Then
            Set tWB = Workbooks.Open(FileName:=Path & FileName)
            For Each tWS In tWB.Worksheets
                Set uRange = tWS.Range("A1", tWS.Cells(tWS.UsedRange.Row + tWS.UsedRange.Rows _
                .Count - 1, tWS.UsedRange.Column + tWS.UsedRange.Columns.Count - 1))
                If RowCount + uRange.Rows.Count > 65536 Then
                    aWS.Columns.AutoFit
                    Set aWS = mWB.Sheets.Add(After:=aWS)
                    RowCount = 0 
                End If
                If RowCount = 0 Then 
                    aWS.Range("A1", aWS.Cells(1, uRange.Columns.Count)).Value = _
                    tWS.Range("A1", tWS.Cells(1, uRange.Columns.Count)).Value 
                    RowCount = 1 'add one to rowcount
                End If
                aWS.Range("A" & RowCount + 1).Resize(uRange.Rows.Count, uRange.Columns.Count).Value _
                = uRange.Value 
                RowCount = RowCount + uRange.Rows.Count
            Next 
            tWB.Close False 
        End If
        FileName = DIR() 
    Loop
    aWS.Columns.AutoFit
    mWB.Sheets(1).Select 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
     
    Set tWB = Nothing
    Set tWS = Nothing
    Set mWB = Nothing
    Set aWS = Nothing
    Set uRange = Nothing
End Sub

Thanks in advance!

 

[Trevor G]

Try this out, you will have to adjust a couple of things

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> Open_My_Files()<br><SPAN style="color:#00007F">Dim</SPAN> mypath <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> MyFile <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>mypath = "M:\Access Files\"<br>MyFile = Dir(mypath)<br>Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>Application.Calculation = xlCalculationManual<br>Application.DisplayAlerts = <SPAN style="color:#00007F">False</SPAN><br><br>Sheets("sheet1").Range("A1") = "Headings"<br><SPAN style="color:#00007F">Do</SPAN> <SPAN style="color:#00007F">While</SPAN> MyFile <> ""<br><SPAN style="color:#00007F">If</SPAN> MyFile <SPAN style="color:#00007F">Like</SPAN> "*.xls" <SPAN style="color:#00007F">Then</SPAN><br>Workbooks.Open mypath & MyFile<br>Sheets(1).UsedRange.Copy<br><br>ActiveWorkbook.Close <SPAN style="color:#00007F">True</SPAN><br>Range("A6000").Select<br>Range("A" & Rows.Count).End(xlUp).Select<br>ActiveCell.Offset(1, 0).PasteSpecial xlPasteAll<br><br>Cells.PasteSpecial xlPasteAll<br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>MyFile = Dir<br><SPAN style="color:#00007F">Loop</SPAN><br>Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br>Application.Calculation = xlCalculationAutomatic<br>Application.DisplayAlerts = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[AlphaFrog]

Not tested...

Sub CombineSheetsFromAllFilesInADirectory()
     
    Dim Path            As String
    Dim FileName        As String
    Dim tWB             As Workbook
    Dim tWS             As Worksheet
    Dim mWB             As Workbook
    Dim aWS             As Worksheet
    Dim RowCount        As Long
    Dim uRange          As Range

    Path = "C:\"
     
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set mWB = Workbooks.Add(1)
    Set aWS = mWB.ActiveSheet

    If Right(Path, 1) <> Application.PathSeparator Then
        Path = Path & Application.PathSeparator
    End If
    FileName = Dir(Path & "*.xls", vbNormal)
    Do Until FileName = ""
        If Path <> ThisWorkbook.Path Or FileName <> ThisWorkbook.Name Then
            Set tWB = Workbooks.Open(FileName:=Path & FileName)
            
[COLOR="Red"]            Set tWS = Nothing
            On Error Resume Next
                Set tWS = tWB.Sheets("Container Info")
            On Error GoTo 0
            If Not tWS Is Nothing Then[/COLOR]
                
                Set uRange = tWS.Range("A1", tWS.Cells(tWS.UsedRange.Row + tWS.UsedRange.Rows _
                .Count - 1, tWS.UsedRange.Column + tWS.UsedRange.Columns.Count - 1))
                If RowCount + uRange.Rows.Count > 65536 Then
                    aWS.Columns.AutoFit
                    Set aWS = mWB.Sheets.Add(After:=aWS)
                    RowCount = 0
                End If
                If RowCount = 0 Then
                    aWS.Range("A1", aWS.Cells(1, uRange.Columns.Count)).Value = _
                    tWS.Range("A1", tWS.Cells(1, uRange.Columns.Count)).Value
                    RowCount = 1 'add one to rowcount
                End If
                aWS.Range("A" & RowCount + 1).Resize(uRange.Rows.Count, uRange.Columns.Count).Value _
                = uRange.Value
                RowCount = RowCount + uRange.Rows.Count
                
[COLOR="Red"]            End If[/COLOR]
            tWB.Close False
        End If
        FileName = Dir()
    Loop
    aWS.Columns.AutoFit
    mWB.Sheets(1).Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
     
    Set tWB = Nothing
    Set tWS = Nothing
    Set mWB = Nothing
    Set aWS = Nothing
    Set uRange = Nothing
    
End Sub

 

[jammer12001]

Great!

Alpha yours worked perfect.

Trevor I couldn't get yours to work. Pretty good chance it is just a ID10T error though.