I am trying to get a set of Excel files that are unique by campaign type with pivot tables for geographic regions in separate worksheets to instead be pasted values for each campaign type in separate worksheets in unique geographic region Excel files. I first change the .xlsx files to instead be .xls files (not sure why I had to but my code wouldn't progress otherwise). This works ok, but when proceeding through the list of geographic regions (range in Zones files), if a non-match is found for one of the campaign types (i.e., campaign not run in that geography), then the code errors out on the fn = Dir line. To mitigate this error, I tried changing the method to instead create a filename to store each geography (as in https://www.experts-exchange.com/qu...g-Dir-Invalid-procedure-call-or-argument.html), but I ran into another problem). Any help would be appreciated. I guess I can always re-do my overall work design, but I thought this wouldn't be that tough. Now, I'm just frustrated and want the issue resolved. Please educate me - Thanks!
Sub CombineWorkbooks()
Dim range1 As Range
Dim cell As Range
Dim Filename, Pathname, Pathname2, saveFileName As String
Dim wk As Workbook
Dim wo As Workbook
Dim initialDisplayAlerts As Boolean
Dim fn As String
Dim WSName As String
Dim wb As Excel.Workbook
Dim WT As Object
Dim wb1 As Excel.Workbook
Dim wb2 As Excel.Workbook
Pathname = "C:\Users\jdoe\Desktop\Client”
Pathname2 = "C:\Users\jdoe\Desktop\Client\Revised\”
Filename = Dir(Pathname & "*.xlsx")
initialDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
'Need to convert to .xls for some reason for macro to work
Do While Filename <> ""
Set wk = Workbooks.Open(Filename:=Pathname & Filename, _
UpdateLinks:=False)
wk.CheckCompatibility = False
saveFileName = Replace(Filename, ".xlsx", ".xls")
wk.SaveAs Filename:=Pathname & saveFileName, _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
wk.Close SaveChanges:=False
If Right(Filename, 4) = "xlsx" Then Kill Pathname & Filename
Filename = Dir()
Loop
Application.DisplayAlerts = initialDisplayAlerts
Set wo = Workbooks.Open("Jdoe\Desktop\Client\Zones.xls")
Set range1 = wo.Sheets("Zones").Range("A1:A26")
For Each cell In range1
WSName = cell
On Error GoTo Nxt
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fn = Dir(MyPathName & "\*.xls")
Do While fn <> ""
Set wb = Application.Workbooks.Open(MyPathName & "" & fn)
If MySheetExists(wb, WSName) Then
' Sheet name exists
Else
ActiveWorkbook.Close (False)
GoTo Nxt
End If
With Workbooks.Open(MyPathName & "" & fn)
With .Sheets(WSName)
.Name = Left(fn, Application.WorksheetFunction.Find("(", fn) - 2)
.Copy After:=ThisWorkbook.Sheets(1)
End With
.Close False
End With
Nxt:
fn = Dir
Loop
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Add
For Each WT In wb1.Sheets
If WT.Name <> "Sheet1" Then
WT.Move After:=wb2.Sheets(wb2.Sheets.Count)
End If
Next WT
For Each WT In wb2.Sheets
WT.Cells.Copy
WT.Cells.PasteSpecial xlPasteValues
Next WT
Application.CutCopyMode = False
wb2.Sheets("Sheet1").Delete
wb2.SaveAs Filename:=Pathname2 & WSName & ".xls"
Next cell
End Sub
Public Function MySheetExists(wb As Excel.Workbook, WSName As String) As Boolean
Dim WS As Excel.Worksheet
On Error Resume Next
Application.DisplayAlerts = True
Set WS = wb.Worksheets(WSName)
MySheetExists = Not (WS Is Nothing)
End Function
Sub CombineWorkbooks()
Dim range1 As Range
Dim cell As Range
Dim Filename, Pathname, Pathname2, saveFileName As String
Dim wk As Workbook
Dim wo As Workbook
Dim initialDisplayAlerts As Boolean
Dim fn As String
Dim WSName As String
Dim wb As Excel.Workbook
Dim WT As Object
Dim wb1 As Excel.Workbook
Dim wb2 As Excel.Workbook
Pathname = "C:\Users\jdoe\Desktop\Client”
Pathname2 = "C:\Users\jdoe\Desktop\Client\Revised\”
Filename = Dir(Pathname & "*.xlsx")
initialDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
'Need to convert to .xls for some reason for macro to work
Do While Filename <> ""
Set wk = Workbooks.Open(Filename:=Pathname & Filename, _
UpdateLinks:=False)
wk.CheckCompatibility = False
saveFileName = Replace(Filename, ".xlsx", ".xls")
wk.SaveAs Filename:=Pathname & saveFileName, _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
wk.Close SaveChanges:=False
If Right(Filename, 4) = "xlsx" Then Kill Pathname & Filename
Filename = Dir()
Loop
Application.DisplayAlerts = initialDisplayAlerts
Set wo = Workbooks.Open("Jdoe\Desktop\Client\Zones.xls")
Set range1 = wo.Sheets("Zones").Range("A1:A26")
For Each cell In range1
WSName = cell
On Error GoTo Nxt
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fn = Dir(MyPathName & "\*.xls")
Do While fn <> ""
Set wb = Application.Workbooks.Open(MyPathName & "" & fn)
If MySheetExists(wb, WSName) Then
' Sheet name exists
Else
ActiveWorkbook.Close (False)
GoTo Nxt
End If
With Workbooks.Open(MyPathName & "" & fn)
With .Sheets(WSName)
.Name = Left(fn, Application.WorksheetFunction.Find("(", fn) - 2)
.Copy After:=ThisWorkbook.Sheets(1)
End With
.Close False
End With
Nxt:
fn = Dir
Loop
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Add
For Each WT In wb1.Sheets
If WT.Name <> "Sheet1" Then
WT.Move After:=wb2.Sheets(wb2.Sheets.Count)
End If
Next WT
For Each WT In wb2.Sheets
WT.Cells.Copy
WT.Cells.PasteSpecial xlPasteValues
Next WT
Application.CutCopyMode = False
wb2.Sheets("Sheet1").Delete
wb2.SaveAs Filename:=Pathname2 & WSName & ".xls"
Next cell
End Sub
Public Function MySheetExists(wb As Excel.Workbook, WSName As String) As Boolean
Dim WS As Excel.Worksheet
On Error Resume Next
Application.DisplayAlerts = True
Set WS = wb.Worksheets(WSName)
MySheetExists = Not (WS Is Nothing)
End Function
