Problems with copying multiple worksheets into one workbook

[theresu]

I'm trying to copy 70 different Excel-files into one workbook. I have script which are able to put togheter upto 11 different files into one workbook. But after this it starts to copy the same name over again. Can anyone help me to modify my script? I'm a Newbeginner in this.

Here is my script:

Sub Merge2MultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    MyPath = "H:\My Documents\Test"
    Set wbDst = Workbooks.Add(xlWBATWorksheet)
    strFilename = Dir(MyPath & "\*.xls", vbNormal)
    
    If Len(strFilename) = 0 Then Exit Sub
    
    Do Until strFilename = ""
        
            Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
            
            Set wsSrc = wbSrc.Worksheets(1)
            
            wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
            
            wbSrc.Close False
        
        strFilename = Dir()
        
    Loop
    wbDst.Worksheets(1).Delete
    
    End Sub

It seems to me that this line is the problem

 wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)

Since all my worksheets have the same name, when it put's them into the New workbook, it gives it a number at the end. When it come to 10, it stops. How do I make it add more worksheets?

[mancubus]

welcome to vbax.

tested with 200 files with success

credits: snb / kh

Sub vbax_54318_Consolidate_WorkSheets_From_files_In_Same_Folder()

    Dim FolderPath As String
    Dim FilesInFolder
    Dim j As Long, calc As Long
    Dim wbDst As Workbook

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .AskToUpdateLinks = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With

    FolderPath = "H:\My Documents\Test\"
    FilesInFolder = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir """ & FolderPath & "*.xl??"" /b").StdOut.ReadAll, vbCrLf)
    
    Set wbDst = Workbooks.Add(xlWBATWorksheet)
    
    For j = LBound(FilesInFolder) To UBound(FilesInFolder)
        If Len(FilesInFolder(j)) > 4 Then
            With GetObject(FolderPath & FilesInFolder(j))
                    .Worksheets(1).Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
                    ActiveSheet.Name = "wb_" & j 'change copied sheet name to workbook's index number in array. you may wish to change this naming structure.
                    .Close 0
            End With
        End If
    Next

    wbDst.Worksheets(1).Delete

    With Application
        .EnableEvents = True
        .AskToUpdateLinks = True
        .Calculation = calc
    End With

End Sub

[theresu]

Thanks! I able to run the script now. I had another problem as well. My filename contained special characters (ø æ å) in Norwegian which it didn't like when it read the files. But now it works!

[mancubus]

welcome.

then vba Dir function as in your first post is our friend...

Sub vbax_54318_Consolidate_WorkSheets_From_files_In_Same_Folder_v2()

    Dim FolderPath As String, FilesInFolder As String
    Dim j As Long, calc As Long
    Dim wbDst As Workbook

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .AskToUpdateLinks = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With

    FolderPath = "H:\My Documents\Test\"
    
    Set wbDst = Workbooks.Add(xlWBATWorksheet)
    
    FilesInFolder = Dir(FolderPath & "*.xl??")

    Do While FilesInFolder <> ""
        Set wb = Workbooks.Open(FolderPath & FilesInFolder)
        With ActiveWorkbook
            .Worksheets(1).Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
            ActiveSheet.Name = "wb_" & j
            .Close 0
        End With
        j = j + 1
        FilesInFolder = Dir()
    Loop
    
    wbDst.Worksheets(1).Delete

    With Application
        .EnableEvents = True
        .AskToUpdateLinks = True
        .Calculation = calc
    End With

End Sub

[mancubus]

you can use v1 via a UDF

Sub vbax_54318_Consolidate_WorkSheets_From_files_In_Same_Folder_v1()

    Dim FolderPath As String, tempStr As String
    Dim FilesInFolder
    Dim j As Long, calc As Long
    Dim wbDst As Workbook

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .AskToUpdateLinks = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With

    FolderPath = "H:\My Documents\Test\"
    FilesInFolder = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir """ & FolderPath & "*.xl??"" /b").StdOut.ReadAll, vbCrLf)
    
    Set wbDst = Workbooks.Add(xlWBATWorksheet)
    
    For j = LBound(FilesInFolder) To UBound(FilesInFolder)
        If Len(FilesInFolder(j)) > 4 Then
            tempStr = FilesInFolder(j)
            tempStr = StripAccentNorsk(tempStr)
            FilesInFolder(j) = tempStr
            With GetObject(FolderPath & FilesInFolder(j))
                    .Worksheets(1).Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
                    ActiveSheet.Name = "wb_" & j
                    .Close 0
            End With
        End If
    Next

    wbDst.Worksheets(1).Delete

    With Application
        .EnableEvents = True
        .AskToUpdateLinks = True
        .Calculation = calc
    End With

End Sub
 



Function StripAccentNorsk(thestring As String)
'http://www.extendoffice.com/documents/excel/707-excel-replace-accented-characters.html

    Dim A As String, B As String
    Dim i As Integer
    Const AccChars = "’‘�›�†"
    Const RegChars = "ÆæØøÅå"
    
    For i = 1 To Len(AccChars)
        A = Mid(AccChars, i, 1)
        B = Mid(RegChars, i, 1)
        thestring = Replace(thestring, A, B)
    Next
    
    StripAccentNorsk = thestring

End Function

[theresu]

Thanks a lot Mangubus. That solved the problem With my Norwegian characters.

[mancubus]

you are welcome.

mark the thread as solved from thread tools pls.