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.