如何使用VBA从工作簿中保存特定工作表？

Question

Objective:

1. To save specific worksheets in a workbook as unique CSV files

Conditions:

1. To save specific worksheets (plural) from a workbook that contains both the specific worksheets and extraneous worksheets (eg to save specific 10 out of 20 available worksheets)
2. Insert the current date into the CSV's file name in order to avoid overwriting files currently in the save folder (this VBA is run daily)
3. File name syntax: CurrentDate_WorksheetName.csv

I've found VBA code that gets me half way to my goal. It saves ALL worksheets in the workbook but the file name is not dynamic with the current date.

Current Code:

Private Sub SaveWorksheetsAsCsv()

Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim DateToday As Range


Dim CurrentWorkbook As String
Dim CurrentFormat As Long


CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook
SaveToDirectory = "S:\test\"
For Each WS In ThisWorkbook.Worksheets
    Sheets(WS.Name).Copy
    ActiveWorkbook.SaveAs Filename:=SaveToDirectory & WS.Name & ".csv", FileFormat:=xlCSV
    ActiveWorkbook.Close savechanges:=False
    ThisWorkbook.Activate
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

Answer 1

There are several issues with your code:

i) There is no reason to save the format or name of your current workbook. Just use a new workbook to save the CSVs that you want.

ii) You were copying each worksheet in the book, but not copying it anywhere. This code was actually saving the same workbook with the name of each sheet. Copying the worksheet doesn't paste it anywhere and doesn't actually tell the saving function only to use parts of the document.

iii) To put the date in the name, you just need to append it to the save name string, as below.

 Dim myWorksheets() As String 'Array to hold worksheet names to copy
 Dim newWB As Workbook
 Dim CurrWB As Workbook
 Dim i As Integer


 Set CurrWB = ThisWorkbook

 SaveToDirectory = "S:\test\"


 myWorksheets = Split("SheetName1, SheetName2, SheetName3", ",")
 'this contains an array of the sheets.  
 'If you want more, put another comma and then the next sheet name.
 'You need to put the real sheet names here.

 For i = LBound(myWorksheets) To UBound(myWorksheets) 'Go through entire array

      Set newWB = Workbooks.Add 'Create new workbook

      CurrWB.Sheets(Trim(myWorksheets(i))).Copy Before:=newWB.Sheets(1)
      'Copy worksheet to new workbook
      newWB.SaveAs Filename:=SaveToDirectory & Format(Date, "yyyymmdd") & myWorksheets(i), FileFormat:=xlCSV
      'Save new workbook in csv format to requested directory including date.
      newWB.Close saveChanges:=False 
      'Close new workbook without saving (it is already saved)

 Next i

 CurrWB.Save 'save original workbook.

 End Sub

Answer 2

It seems to me that in that code was a lot of unnecessary stuff but the most important part was almost ready. Try this:

Sub SaveWorksheetsAsCsv()

Dim WS As Worksheet
Dim SaveToDirectory As String

SaveToDirectory = "C:\tmp\"

Application.DisplayAlerts = False

For Each WS In ThisWorkbook.Worksheets
    WS.SaveAs Filename:=SaveToDirectory & Format(Now(), "yyyymmdd") & "_" & WS.Name & ".csv", FileFormat:=xlCSV
Next

Application.DisplayAlerts = True

End Sub