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

Question

目的：

1. 將工作簿中的特定工作表另存為唯一的CSV文件

條件：

1. 若要從包含特定工作表和無關工作表的工作簿中保存特定工作表（復數個）（例如，從20個可用工作表中保存特定10個）
2. 將當前日期插入CSV的文件名中，以避免覆蓋當前保存文件夾中的文件（此VBA每天運行）
3. 文件名語法：CurrentDate_WorksheetName.csv

我發現VBA代碼可以使我達到目標的一半。 它將所有工作表保存在工作簿中，但文件名不會隨當前日期動態變化。

當前代碼：

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

您的代碼有幾個問題：

i）沒有理由保存您當前工作簿的格式或名稱。 只需使用新的工作簿來保存所需的CSV。

ii）您正在復制書中的每個工作表，但沒有將其復制到任何地方。 該代碼實際上是使用每個工作表的名稱保存同一工作簿。 復制工作表不會將其粘貼到任何地方，實際上並不會告訴保存功能僅使用文檔的某些部分。

iii）要將日期放入名稱中，只需將其附加到保存名稱字符串中，如下所示。

 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

在我看來，該代碼中有很多不必要的東西，但最重要的部分幾乎已經准備就緒。 嘗試這個：

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