Hi everyone,
I'm having a hard time trying to combine some data from 2 workbooks (A and B).
What I'm trying to do, is to take the Worksheets with the same name from A and B create a new Workbook with 2 Sheets (Sheet A and Sheet B).
But there are also some other Sheets that don't have a similar name in these 2 Workbooks. So i need to export them into a new workbook by themselves.
Here is my attempt:
After executing this function, the program bugs and not all the worksheets are copied.
Hope someone can help me with this.
Thank you !
I'm having a hard time trying to combine some data from 2 workbooks (A and B).
What I'm trying to do, is to take the Worksheets with the same name from A and B create a new Workbook with 2 Sheets (Sheet A and Sheet B).
But there are also some other Sheets that don't have a similar name in these 2 Workbooks. So i need to export them into a new workbook by themselves.
Here is my attempt:
Code:
Function createWorkbooks() Dim wbks(1 To 2) As Workbook
Dim wbTemp As Workbook
Dim wsA, wsB As Worksheet
Dim strPath As String
Dim intPath, i As Integer
'Select workbooks
For i = 1 To 2 'loop 2 times to select 2 files
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False 'select 1 file at a time
intPath = .Show 'show file box
If intPath <> 0 Then 'verify if a file has been selected
strPath = .SelectedItems(1) 'select file path
Else
MsgBox "Workbook not selected. Exiting." 'if nothing is selected
Exit Function 'close
End If
End With
Set wbks(i) = Workbooks.Open(strPath) 'open selected file
Next i
'Loop on first file sheets
For Each wsA In wbks(1).Worksheets
For Each wsB In wbks(2).Worksheets
If wsA.Name = wsB.Name Then 'verify if some sheets have the same name
Set wbTemp = Application.Workbooks.Add 'create wb
With wbTemp
wsA.Copy after:=.Sheets(.Sheets.Count) 'copy sheets into the new file
.Sheets(.Sheets.Count).Name = wsA.Name & "-A" 'add the letter A to the first sheet
wsB.Copy after:=.Sheets(.Sheets.Count) 'copy sheets into wb
.Sheets(.Sheets.Count).Name = wsB.Name & "-B" 'add the letter B to the second
'Supprimer les feuilles vides
Application.DisplayAlerts = False
.Sheets("Sheet1").Delete
.Sheets("Sheet2").Delete
.Sheets("Sheet3").Delete
wbTemp.SaveAs Filename:=wbks(1).Path & "\" & wsA.Name
wbTemp.Close savechanges:=False
Application.DisplayAlerts = True
End With
Else
If Dir(wbks(1).Path & "\" & wsA.Name, vbDirectory) = vbNullString Then
wsA.Copy
Application.ActiveWorkbook.SaveAs Filename:=wbks(1).Path & "\" & wsA.Name
Application.ActiveWorkbook.Close False
End If
If Dir(wbks(1).Path & "\" & wsB.Name, vbDirectory) = vbNullString Then
wsB.Copy
Application.ActiveWorkbook.SaveAs Filename:=wbks(1).Path & "\" & wsB.Name
Application.ActiveWorkbook.Close False
End If
End If
Next wsB
Next wsA
End FunctionAfter executing this function, the program bugs and not all the worksheets are copied.
Hope someone can help me with this.
Thank you !
