在删除空白或“空白”但包含公式的行后，将工作表作为CSV文件导出到特定位置的VBA脚本

Question

我正在开发一个VBA脚本，允许从Excel工作簿中操作和导出许多工作表作为csv文件。我希望能够将指定工作表的列表作为csv文件导出到能够选择的保存位置，此外，特定列中任何空白但可能包含公式的单元格需要具有整个行已删除。下面的脚本是我目前所拥有的，它似乎有点工作，但有三个主要问题：

1. 如果A列中的单元格确实为空，即不包含公式，则下面的行将删除行，但如果存在公式则不起作用：Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
2. 通过工作表循环是不整洁但功能，有没有办法使用命名工作表列表，使脚本更简洁？
3. 理想情况下，保存位置也可以从选择文件目录对话框中选择。有关如何实现这一目标的任何建议？

提前谢谢了。

Sub createCSVfiles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Declare and set variables
Dim wb1 As Workbook, ws1 As Worksheet
Dim wbname As String, i As Integer
Set wb1 = ThisWorkbook

'Cycle through sheets
For i = 1 To Worksheets.Count
    wbname = Worksheets(i).Name

'Create Sheet1.csv
  If InStr(1, (Worksheets(i).Name), "Sheet1", vbTextCompare) > 0 Then
       Worksheets(i).Copy
       Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
       ActiveWorkbook.SaveAs Filename:="C:\Users\forename.surname\Desktop\export\" & ActiveSheet.Name & ".csv", _
       FileFormat:=xlCSV, CreateBackup:=False
       ActiveWorkbook.Close
      wb1.Activate
End If

'Create Sheet2.csv
If InStr(1, (Worksheets(i).Name), "Sheet2", vbTextCompare) > 0 Then
    Worksheets(i).Copy
    ActiveWorkbook.SaveAs Filename:="C:\Users\forename.surname\Desktop\export\" & ActiveSheet.Name & ".csv", _
    FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close
    wb.Activate
End If

Next i

'Clean
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Answer 1

我觉得这样的东西就是你要找的东西：

Sub createCSVfiles()

    'Declare and set variables
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsTemp As Worksheet
    Dim aSheets() As Variant
    Dim vSheet As Variant
    Dim sFilePath As String
    Dim sNewFileName As String
    Dim oShell As Object
    Dim i As Long

    'Select folder to save CSV files to
    Set oShell = CreateObject("Shell.Application")
    On Error Resume Next
    sFilePath = oShell.BrowseForFolder(0, "Select folder to save csv files", 0).Self.Path & Application.PathSeparator
    On Error GoTo 0
    If Len(sFilePath) = 0 Then Exit Sub 'Pressed cancel

    'Define sheet names here
    aSheets = Array("Sheet1", "Sheet2")

    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Set wb = ThisWorkbook

    'Cycle through sheets
    For Each vSheet In aSheets
        'Test if sheet exists
        Set ws = Nothing
        On Error Resume Next
        Set ws = wb.Sheets(vSheet)
        On Error GoTo 0
        If Not ws Is Nothing Then
            'Sheet exists
            ws.Copy
            Set wsTemp = ActiveSheet

            'Remove rows with blanks in column A
            With wsTemp.Range("A1", wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp))
                .AutoFilter 1, "=", xlFilterValues
                .Offset(1).EntireRow.Delete
                .AutoFilter
            End With

            'Save and close
            wsTemp.Parent.SaveAs sFilePath & wsTemp.Name & ".csv", xlCSV
            wsTemp.Parent.Close False
        End If
    Next vSheet

    'Clean
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub