VBA code to delete sheets with partial name is not working - excel

I am trying to create code that will delete all sheets in active workbook if name contains part text from input. So far nothing seems working and I have no clue why.
I am using this code:
Private Sub CommandButton28_Click()
Dim shName As String
Dim xName As String
Dim xWs As Worksheet
Dim cnt As Integer
shName = Application.InputBox("Enter the specific text:", "Delete sheets", _
ThisWorkbook.ActiveSheet.Name, , , , , 2)
If shName = "" Then Exit Sub
xName = "*" & shName & "*"
' MsgBox xName
Application.DisplayAlerts = False
cnt = 0
For Each xWs In ThisWorkbook.Sheets
If xWs.Name Like xName Then
xWs.Delete
cnt = cnt + 1
End If
Next xWs
Application.DisplayAlerts = True
MsgBox "Have deleted " & cnt & " worksheets", vbInformation, "Sheets removed"
End Sub
But when I enter specific text (no spaces before or after) it doesn't work. Any ideas how to fix it?
Here is data from sheet where I tested it: Sheets names
And here is the result of macro: Result of macro

Like is case sensitive. Try making the following changes to your code (please see comments starting with '****)
Private Sub CommandButton28_Click()
Dim shName As String
Dim xName As String
Dim xWs As Worksheet
Dim cnt As Integer
shName = Application.InputBox("Enter the specific text:", "Delete sheets", _
ThisWorkbook.ActiveSheet.Name, , , , , 2)
If shName = "" Then Exit Sub
'**** use LCase() here
xName = "*" & LCase(shName) & "*"
' MsgBox xName
Application.DisplayAlerts = False
cnt = 0
For Each xWs In ThisWorkbook.Sheets
'**** Use LCase() here
If LCase(xWs.Name) Like xName Then
xWs.Delete
'MsgBox xName
cnt = cnt + 1
End If
Next xWs
Application.DisplayAlerts = True
MsgBox "Have deleted " & cnt & " worksheets", vbInformation, "Sheets removed"
End Sub
Please also note that your code doesn't check if the sheet to be deleted is the only sheet in the workbook (will raise an error). Furthermore, if the user sends * (intentionally or by mistake) your code will delete all sheets except one. This is dangerous, so please think about your code strategy and act accordingly. An idea is to save a backup copy before deleting the sheets
Sub BackupWorkbook(wb As Workbook)
wb.SaveCopyAs "FULL_BACKUP_PATH" & Format(Now, "yyyymmddhhmmss") & ThisWorkbook.Name
End Sub

The problem with like is it is expecting one char when using *Name*.
You can use InStr to find your string:
If InStr(1, xWs.Name, shName ) > 0 Then
xWs.Delete
cnt = cnt + 1
End If

You must use InStr instead of 'like' and loop from last sheet to first sheet
For i = ThisWorkbook.Sheets.Count To 1 Step -1
Set xWs = ThisWorkbook.Sheets(i)
If InStr(xWs.Name, shName ) > 0 Then
xWs.Delete
cnt = cnt + 1
End If
Next i

Related

How to delete multiple sheets using input box

Just need some help. I want to delete multiple sheets using their partial name that I will enter in the input box. Is there any code that I can add multiple partial names in input box so they will be deleted at once?
For example, I would like to add these partial names: "Pivot", "IWS, "Associate", "Split", and "Invoice"
My initial code can delete sheets with just one partial name, sample if I enter "Pivot" it will delete all sheets with "Pivot" name. I want to tweak my code where I can add multiple partial name to the input box.
Here's the initial code:
Sub ClearAllSheetsSpecified()
'----------------------------------------------------------------------------------------------------------
' Clear all sheets specified in input box
'----------------------------------------------------------------------------------------------------------
Dim shName As String
Dim xName As String
Dim xWs As Worksheet
Dim cnt As Integer
shName = Application.InputBox("Enter the sheet name to delete:", "Delete sheets", _
ThisWorkbook.ActiveSheet.Name, , , , , 2)
If shName = "" Then Exit Sub
'**** use LCase() here
xName = "*" & LCase(shName) & "*"
' MsgBox xName
Application.DisplayAlerts = False
cnt = 0
For Each xWs In ThisWorkbook.Sheets
'**** Use LCase() here
If LCase(xWs.Name) Like xName Then
xWs.Delete
'MsgBox xName
cnt = cnt + 1
End If
Next xWs
Application.DisplayAlerts = True
MsgBox "Have deleted " & cnt & " worksheets", vbInformation, "Sheets removed"
I'm looking for a code that I can enter any partial name in my input box then sheets will be deleted as long as they exist in my current WB.
This is a way to capture your list of phrases. The input text must have a common delimiter that you code for. In this case I used the semi-colon.
Sub testIt()
Dim shName As String
Dim xName() As String
Dim cnt As Integer
shName = Application.InputBox("Enter the sheet names (delimited by ;) to delete:", "Delete sheets", _
ThisWorkbook.ActiveSheet.Name, , , , , 2)
If shName = "" Then Exit Sub
'**** use LCase() here
xName = Split(LCase(shName), ";")
For x = 0 To UBound(xName)
Debug.Print "*" & xName(x) & "*"
'do your delete
Next x
End Sub

Rename Multiple sheets in Excel with cell value from same sheet in VBA

I am currently working on a VBA project. I have a workbook with multiple tabs from different workbooks. The names of all the tabs are the same, however since they come from different files, I would like to name them based on the filenames they are extracted from. The filenames are present in the cell EC1 of every tab. I would like to name all the sheets in the workbook based on the value present in cell EC1 of each individual sheet.
I have the following code:
Sub RenameSheet()
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = rs.Range("EC1")
Next rs
End Sub
I have been getting a 1004 error from the above code.
I tried this code too:
Sub RenameSheet()
Dim xWs As Worksheet
Dim xRngAddress As String
Dim xName As String
Dim xSSh As Worksheet
Dim xInt As Integer
xRngAddress = Application.ActiveCell.Address
On Error Resume Next
Application.ScreenUpdating = False
For Each xWs In Application.ActiveWorkbook.Sheets
xName = xWs.Range(xRngAddress).Value
If xName <> "" Then
xInt = 0
Set xSSh = Nothing
Set xSSh = Worksheets(xName)
While Not (xSSh Is Nothing)
Set xSSh = Nothing
Set xSSh = Worksheets(xName & "(" & xInt & ")")
xInt = xInt + 1
Wend
If xInt = 0 Then
xWs.Name = xName
Else
If xWs.Name <> xName Then
xWs.Name = xName & "(" & xInt & ")"
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Some sheets do get renamed, however some do not. I have checked for duplicate sheet names, and there are none. I have also checked if the filename is in the correct range (cell), and it is present.
There might be problems with the value if it contains some special characters. The excel sheets can have some restrictions for their names, if thats the problem, my code could be the solution.
It cuts the string to a maximum length of 31 chars and deletes all the special chars which are not allowed in names.
Sub RenameSheet()
Dim rs As Worksheet
For Each rs In Sheets
sheetName = without_special_chars(rs.Range("EC1").Value)
If Len(sheetName) > 31 Then
sheetName = Left(sheetName, 31)
End If
rs.Name = sheetName
Next rs
End Sub
Function without_special_chars(text As String) As String
Dim i As Integer
Const special_chars As String = "-.,:;#+ß'*?=)(/&%$§!~\}][{"
For i = 1 To Len(special_chars)
text = Replace(text, Mid(special_chars, i, 1), "")
Next i
without_special_chars = text
End Function
Rename Multiple Worksheets
A Quick Fix
Your first code should have been something like this:
Sub renameWorksheetsQF()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Name = ws.Range("EC1").Value
Next ws
End Sub
Note the not so subtile differences.
In Depth
Option Explicit
Sub renameWorksheets()
On Error GoTo clearError
Const cAddress As String = "A1" ' "EC1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet
Dim cel As Range
Dim oName As String
Dim nName As String
For Each ws In wb.Worksheets
oName = ws.Name
Set cel = ws.Range(cAddress)
If IsError(cel) Then
Debug.Print "Cell '" & cAddress & "' in worksheet '" _
& oName & "' contains the error value '" & cel.Text & "'."
Else
If IsEmpty(cel) Then
Debug.Print "Cell '" & cAddress & "' in worksheet '" _
& oName & "' is an empty cell."
Else
nName = CStr(cel.Value)
On Error GoTo RenameError
If oName <> nName Then
ws.Name = nName
Else
Debug.Print "Worksheet '" & oName _
& "' had previously been renamed."
End If
On Error GoTo clearError
End If
End If
Next ws
ProcExit:
Exit Sub
RenameError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Debug.Print " Could not rename '" & oName & "' to '" & nName & "'."
Resume Next
clearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Debug.Print " Unexpected error."
Resume ProcExit
End Sub

VBA to Update and Replace in Workbooks causes crashing

Please bear with me. My code is probably complete shit, so I appreciate all feedback! So what this does is, on my main workbook, there are a bunch of UNC hyperlinks in Row M, that link to files in a section drive.
What this code does:
Go down the list of hyperlinks in Column M, opens them up and executes the code inside of the "With WBSsource".
First, it searches for instances of the incorrect filepath (st) inside each of the cells formulas (NOT VALUES), and increments a counter using InStr (t), then after the worksheet has been searched, if the final count (c) is more than 0, meaning the search found at least one incorrect filepath, it will proceed to the next step.
It does a Cells.Replace on a worksheet (ws.) basis (at the FORMULA level)
Cells per worksheet are all done, it should save the workbook and close it before moving onto the next one.
Any links that could not be opened will appear in a final popup.
It is by Step 3 that it starts to run sluggish and crash.
I'm trying my best to get this automated and saving the workbooks. Then, once they're all updated, running this code again would be much faster cause it won't have to replace everything again.
Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
Dim ws As Worksheet
Dim r As Range, t As Long, c As Integer
' Update the individual credit models
With ThisWorkbook.ActiveSheet
lr = .Cells(.Rows.Count, "M").End(xlUp).Row
FileNames = .Range("M2:M" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
On Error Resume Next
If FileNames(i, 1) Like "*.xls*" Then
Set WBSsource = Workbooks.Open(FileNames(i, 1), _
ReadOnly:=False, _
Password:="", _
UpdateLinks:=3)
If Err = 0 Then
With WBSsource
Application.DisplayAlerts = False
ActiveWorkbook.Final = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
st = "\\corp\Accounts\" 'Search Phrase
n = "\\corp\StackOverflow\Accounts\" 'New Phrase
c = 0
For Each ws In WBSsource.Worksheets
ws.Activate
t = 0
On Error Resume Next
For Each r In ws.Cells.SpecialCells(xlCellTypeFormulas)
t = InStr(1, r.Formula, st)
If t > 0 Then
c = c + 1
End If
Next r
Next ws
If c > 0 Then
'MsgBox ws.Name & Chr(10) & (c)
ws.Cells.Replace st, n
End If
.UpdateLink Name:=ActiveWorkbook.LinkSources, Type:=xlExcelLinks
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
.Save
.Close True
End With
Else
msg = msg & FileNames(i, 1) & Chr(10) & Chr(10)
On Error GoTo 0
End If
End If
Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
'MsgBox "The Following Files Could Not Be Opened" & _
' Chr(10) & msg, 48, "Error"
Set objShell = CreateObject("Wscript.Shell")
objShell.Popup "The Following Files Could Not Be Opened" & _
Chr(10) & Chr(10) & msg, 48, "Error"
End If
Application.DisplayAlerts = True
End Sub
It's not completely crap. I just learned that we could create an array with this.
FileNames = .Range("M2:M" & lr).Value
It may crash since there's no range limit on the 3rd step. Try getting the last row and column on each worksheet, then create a range based on that.
With ws
' Get end cells
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
For each r in .Range(.Cells(1,1), .Cells(intLastRow, intLastCol))
' Check formula if it contains specific string
t = InStr(1, r.Formula, st)
If t > 0 Then
c = c + 1
End If
' Replace formula with new string
r.Formula = Replace(r.Formula, st, n)
Next r
End With
Edit: Here's the full code. Let me know if this works for you.
Option Explicit
' Update the individual credit models
Sub List_UpdateAndSave()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ErrorHandler
' Declaration
Dim i As Long
Dim arrLinks As Variant
Dim strLinksErr As String
' Initialization
Dim strPathCur As String: strPathCur = "\\corp\Accounts\" ' search phrase
Dim strPathNew As String: strPathNew = "\\corp\StackOverflow\Accounts\" ' new phrase
With ThisWorkbook.ActiveSheet
' Get links from sheet
arrLinks = .Range("M2:M" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Value
End With
For i = LBound(arrLinks, 1) To UBound(arrLinks, 1)
' Check for Excel links
If VBA.InStr(1, arrLinks(i, 1), ".xls", vbTextCompare) > 0 Then
FnExcelUpdateLinks arrLinks(i, 1), strPathCur, strPathNew
Else
' Add to list of links that could not be opened
strLinksErr = strLinksErr & arrLinks(i, 1) & Chr(10)
End If
Next i
ErrorHandler:
' Display any errors
If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, "Error " & Err.Number
' Display any non-Excel links
If strLinksErr <> "" Then
MsgBox "The following files could not be opened:" & _
Chr(10) & strLinksErr, 48, "Error"
End If
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function FnExcelUpdateLinks(ByVal strWbkPath As String, ByRef strPathCur As String, ByRef strPathNew As String)
Dim intLastRow As Long, intLastCol As Long
Dim wbkTmp As Workbook
Dim shtTmp As Worksheet
Dim rngCell As Range
' Open link as workbook
Set wbkTmp = Workbooks.Open(strWbkPath, ReadOnly:=False, Password:="", UpdateLinks:=3)
With wbkTmp
For Each shtTmp In .Worksheets
With shtTmp
' Get end cells
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
For Each rngCell In .Range(.Cells(1, 1), .Cells(intLastRow, intLastCol))
If VBA.InStr(1, rngCell.Formula, strPathCur) > 0 Then
rngCell.Formula = Replace(rngCell.Formula, strPathCur, strPathNew)
End If
Next rngCell
End With
Next shtTmp
.UpdateLink Name:=.LinkSources, Type:=xlExcelLinks
.Save
.Close True
End With
End Function

Renaming Sheets from cells with a loop

The code below is what i use to rename a bunch of sheets within a workbook. it works perfectly. It renames the sheet based off of a cell in that sheet. but now i have two sheets trying to use the same name. So i want to keep the same code but add a loop so if that happens, it will add a "2" to the second sheet. Ie cell contains "John Doe". Sheet will rename to "John Doe" and the next sheet that tries to use it will rename "John Doe 2"
Thank you
Sub RenameLaborLog()
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."
Next rs
End Sub
just to show another way you can reach your goal
Sub RenameLaborLog()
Dim rs As Worksheet, i As Long, str As String
On Error Resume Next
For Each rs In Sheets
str = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."
rs.Name = str
i = 1
While Err.Number <> 0 And i < 20
Err.Clear: i = i + 1
rs.Name = str & i
Wend
If Err.Number <> 0 Then MsgBox "Error: " & rs.Name & " cant be set to any " & str: Exit Sub
Next rs
End Sub
it tries to set the name (and if that is not working it sets the name & 2 - 19 (if that doesnt work, it pops up a message box and exits the sub)
Use a controlled error to adjust the string containing the worksheet name until it find something it can use.
Sub RenameLaborLog()
Dim rs As Worksheet, snam As String, idupe As Long
On Error GoTo bm_Dupe_WS_Name
For Each rs In Sheets
idupe = 1
snam = Split(rs.Range("H4").Value, " ")(1) & ", " & _
Left(Split(rs.Range("H4").Value)(0), 1) & "."
rs.Name = snam
Next rs
bm_Dupe_WS_Name:
If idupe > 8 Then
Debug.Print Err.Number & ": " & snam & " - " & Err.Description
Exit Sub
ElseIf Right(snam, 1) = CStr(idupe) Then
snam = Trim(Left(snam, Len(snam) - 1))
End If
idupe = idupe + 1
snam = snam & Chr(32) & idupe
Resume
End Sub
I have it set yo attempt a numerical suffix up to 9. It it reaches that, it reports the error and exits the sub. I would not recommend running this without an escape clause. If nothing else, you may run into an illegal character when parsing the string for the worksheet name.
Based on the link #Scott Craner provided in his comment, I am providing another solution that I believe is a bit more functional and cleaner and easier to read.
Sub RenameLaborLog()
Dim rs As Worksheet, sName As String
For Each rs In Sheets
sName = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."
i = 1
Do
If Not WorksheetExist(sName) Then
rs.Name = sName
Exit Do
Else: sName = sName & "_" & i + 1
End If
Loop
Next rs
End Sub
Function WorksheetExist(sName As String, Optional wb As Workbook) As Boolean
Dim wbCheck As Workbook, ws As Worksheet
If wb Is Nothing Then Set wbCheck = ThisWorkbook Else: Set wbCheck = wb
WorksheetExist = False
For Each ws In wbCheck.Worksheets
If ws.Name = sName Then
WorksheetExist = True
Exit For
End If
Next
End Function
Jeeped beat me to it, but here is another possible adjustment you could make:
Sub RenameLaborLog()
Dim rs As Worksheet, wsName As String, wsCheck As Worksheet, i As Integer
For Each rs In Sheets
' Get the sheet name
wsName = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."
' Check if it exists
Set wsCheck = Nothing: On Error Resume Next: Set wsCheck = wsName: On Error GoTo 0
' Check if multiples already exist
While Not wsCheck Is Nothing
' If even one exits, "i" will be iterated
i = i + 1
Set wsCheck = Nothing: On Error Resume Next: Set wsCheck = wsName & "_" & i: On Error GoTo 0
Wend
' If at least one name already existed, name it with the current iteration.
If Not i = 0 Then wsName = wsName & "_" & i
rs.Name = wsName
Next rs
Set rs = Nothing: Set wsCheck = Nothing
End Sub

Save each sheet in a workbook to separate CSV files

How do I save each sheet in an Excel workbook to separate CSV files with a macro?
I have an excel with multiple sheets and I was looking for a macro that will save each sheet to a separate CSV (comma separated file). Excel will not allow you to save all sheets to different CSV files.
#AlexDuggleby: you don't need to copy the worksheets, you can save them directly. e.g.:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "C:\"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next
End Sub
Only potential problem is that that leaves your workbook saved as the last csv file. If you need to keep the original workbook you will need to SaveAs it.
Here is one that will give you a visual file chooser to pick the folder you want to save the files to and also lets you choose the CSV delimiter (I use pipes '|' because my fields contain commas and I don't want to deal with quotes):
' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _
"Export To Text File")
'csvPath = InputBox("Enter the full path to export CSV files to: ")
csvPath = GetFolderName("Choose the folder to export CSV files to:")
If csvPath = "" Then
MsgBox ("You didn't choose an export directory. Nothing will be exported.")
Exit Sub
End If
For Each wsSheet In Worksheets
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
wsSheet.Name & ".csv" For Output As #nFileNum
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
Next wsSheet
End Sub
Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean)
Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
And here's my solution should work with Excel > 2000, but tested only on 2007:
Private Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven
' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
' ask the user where to save
OutputPath = InputBox("Enter a directory to save to", "Save to directory", Path)
If OutputPath <> "" Then
' save for each sheet
For Each Sheet In Sheets
OutputFile = OutputPath & "\" & Sheet.Name & ".csv"
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs FileName:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next
End If
Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf
GoTo Finally
End Sub
(OT: I wonder if SO will replace some of my minor blogging)
Building on Graham's answer, the extra code saves the workbook back into it's original location in it's original format.
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook
SaveToDirectory = "C:\"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = True
' Temporarily turn alerts off to prevent the user being prompted
' about overwriting the original file.
End Sub
A small modification to answer from Alex is turning on and off of auto calculation.
Surprisingly the unmodified code was working fine with VLOOKUP but failed with OFFSET. Also turning auto calculation off speeds up the save drastically.
Public Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven
' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
' Save the file in current director
OutputPath = ThisWorkbook.Path
If OutputPath <> "" Then
Application.Calculation = xlCalculationManual
' save for each sheet
For Each Sheet In Sheets
OutputFile = OutputPath & Application.PathSeparator & Sheet.Name & ".csv"
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next
Application.Calculation = xlCalculationAutomatic
End If
Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf
GoTo Finally
End Sub
For Mac users like me, there are several gotchas:
You cannot save to any directory you want. Only few of them can receive your saved files. More info there
Here is a working script that you can copy paste in your excel for Mac:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "~/Library/Containers/com.microsoft.Excel/Data/"
For Each WS In ThisWorkbook.Worksheet
WS.SaveAs SaveToDirectory & WS.Name & ".csv", xlCSV
Next
End Sub
Use Visual Basic to loop through worksheets and save .csv files.
Open up .xlsx file in Excel.
Press option+F11
Insert → Module
Insert this into the module code:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "./"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name & ".csv", xlCSV
Next
End Sub
Run the module.
(i.e. Click the play button at the top and then click "Run" on the dialog, if it pops up.)
Find your .csv files in ~/Library/Containers/com.microsoft.Excel/Data.
open ~/Library/Containers/com.microsoft.Excel/Data
Close .xlsx file.
Rinse and repeat for other .xlsx files.
Please look into Von Pookie's answer, all credits to him/her.
Sub asdf()
Dim ws As Worksheet, newWb As Workbook
Application.ScreenUpdating = False
For Each ws In Sheets(Array("EID Upload", "Wages with Locals Upload", "Wages without Local Upload"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs ws.Name, xlCSV
.Close (False)
End With
Next ws
Application.ScreenUpdating = True
End Sub

Resources