Sub MrE_1225076_161620A()
' https://www.mrexcel.com/board/threads/macro-to-open-multiple-workbook-and-save-as-csv.1225076/
Dim strPath As String
Dim strFile As String
Dim wbkToOpen As Workbook
Dim wksTab As Worksheet
Dim lngNumTabs As Long
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
strPath = "C:\Sales Report\"
strFile = Dir(strPath & "*.xls*")
Do While Len(strFile) > 0
If strFile <> ThisWorkbook.Name Then
Set wbkToOpen = Workbooks.Open(strPath & strFile)
strFile = Left(strFile, InStrRev(strFile, ".") - 1)
If wbkToOpen.Sheets.Count > 1 Then
lngNumTabs = 1
For Each wksTab In wbkToOpen.Worksheets
wksTab.Copy
ActiveWorkbook.SaveAs Filename:=strFile & "-" & lngNumTabs _
& ".csv", FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close False
lngNumTabs = lngNumTabs + 1
Next wksTab
wbkToOpen.Close False
Else
wbkToOpen.SaveAs Filename:=strFile & ".csv", FileFormat:=xlCSV, CreateBackup:=False
wbkToOpen.Close False
End If
End If
strFile = Dir
Loop
Set wbkToOpen = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
EnableEvents
at the start of the procedure and enable at the end.Sub MrE_1225076_161620A_mod01()
' https://www.mrexcel.com/board/threads/macro-to-open-multiple-workbook-and-save-as-csv.1225076/
' Updated: 20221220
' Reason: changed code from all files in folder to selected files only
' CTRL needs to be pressed for selecting multiple files
Dim objFD As FileDialog
Dim lngNumTabs As Long
Dim lngCounter As Long
Dim strFile As String
Dim wbkToOpen As Workbook
Dim wksTab As Worksheet
Set objFD = Application.FileDialog(msoFileDialogFilePicker)
With objFD
.AllowMultiSelect = True
.ButtonName = "Open"
.Title = "Select Files"
.InitialFileName = "C:\Sales Report\"
.Filters.Clear
.Filters.Add "Excel files", "*.xls*"
If objFD.Show = -1 Then
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
For lngCounter = 1 To objFD.SelectedItems.Count
Set wbkToOpen = Workbooks.Open(objFD.SelectedItems(lngCounter))
strFile = Left(wbkToOpen.FullName, InStrRev(wbkToOpen.FullName, ".") - 1)
If wbkToOpen.Sheets.Count > 1 Then
lngNumTabs = 1
For Each wksTab In wbkToOpen.Worksheets
wksTab.Copy
ActiveWorkbook.SaveAs Filename:=strFile & "-" & lngNumTabs _
& ".csv", FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close False
lngNumTabs = lngNumTabs + 1
Next wksTab
wbkToOpen.Close False
Else
wbkToOpen.SaveAs Filename:=strFile & ".csv", FileFormat:=xlCSV, CreateBackup:=False
wbkToOpen.Close False
End If
Next lngCounter
End If
End With
Set wbkToOpen = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub