Enable Your Employees To Focus On The Core With Intuitive Onscreen Guidance That is With You At The Moment of Need.
Private Sub SaveAllSheetsAsCSV() On Error GoTo Heaven ' This creates multipls csv files ' 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 = "C:\temp" 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 Call Wait4Me(50, 1) Call DelSummFile End Sub Public Sub DelSummFile() 'Loop through all the files in the directory by using Dir$ function Dim MyFile As String MyFile = Dir$("c:\temp\Summary.csv") Do While MyFile <> "" KillProperly "c:\temp\" & MyFile 'need to specify full path again because a file was deleted 1 MyFile = Dir$("c:\temp\Summary.csv") Loop End Sub Sub DelFiles() 'Loop through all the files in the directory by using Dir$ function Dim MyFile As String MyFile = Dir$("c:\temp\Sheet*.csv") Do While MyFile <> "" KillProperly "c:\temp\" & MyFile 'need to specify full path again because a file was deleted 1 MyFile = Dir$("c:\temp\sheet*.csv") Loop End Sub Public Sub KillProperly(Killfile As String) If Len(Dir$(Killfile)) > 0 Then SetAttr Killfile, vbNormal Kill Killfile End If End Sub Function Wait4Me(Delay As Integer, DispHrglass As Integer) Dim DelayEnd As Double DoCmd.Hourglass DispHrglass DelayEnd = DateAdd("s", Delay, Now) While DateDiff("s", Now, DelayEnd) > 0 Wend DoCmd.Hourglass False End Function
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
|Modify Array formula - Reduce Calculation Time||4||32|
|Pull Phone Number out of Cell||3||12|
|create multiple records in Excel in 2nd sheet for each record in 1st sheet||10||33|
|Need create populate sheet after selected data||16||14|