Excel-VBA工作表拆分和保存最终出现许多空白行，中间用逗号分隔

Question

我是excel-vba的新手，能够成功将某些列复制到新工作表中并将新工作表另存为单独的csv文件，但是，当我在记事本中打开新创建的文件时，我可以看到大量的逗号，它们代表了很多多余的列。 我添加了另一个步骤，以便在保存之前删除新创建的工作表中的列，但是仍然无法解决该问题。

重申一下，我让用户在一张纸上完成数据，然后在他们单击按钮后，将纸分成两张新纸，然后将每张新纸另存为自己的CSV工作簿。 这些然后在外部使用。 新创建的CSV文件包含过多的以逗号分隔的列，这些列与我的delete column子一起仍然存在。

谢谢！ 克里斯

这是我的代码：

Sub Prepare()
    ReplaceWithValues
    SplitSheet
    ConvertDateFormat
    ExportToCSV
    DeleteSplitSheets
    DisplaySuccess
End Sub

Sub ReplaceWithValues()
' Removes all formulas from Data sheet and pastes only values
    Sheets("Data").Select

    Range("A3").Select
    Range("A3").CurrentRegion.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Range("A1").Select
    Application.CutCopyMode = False

End Sub

Sub SplitSheet()
' Check to see if Contact sheet exists, if not create it
    For i = 1 To Worksheets.Count
    If Worksheets(i).Name = "Contacts" Then
        exists = True
    End If
    Next i

    If Not exists Then
        Worksheets.Add.Name = "Contacts"
    End If
' Splits out Contact data into new sheet for contact export
    Sheets("Data").Columns("A:V").Copy Sheets("Contacts").Range("A1")



' Check to see if Interactions sheet exists, if not create it
    For i = 1 To Worksheets.Count
    If Worksheets(i).Name = "Interactions" Then
        exists = True
    End If
    Next i

    If Not exists Then
        Worksheets.Add.Name = "Interactions"
    End If

' First copy over ID origin and ID to Interactions Sheet
    Sheets("Data").Columns("A:B").Copy Sheets("Interactions").Range("A1")
' Splits out Interaction Data into new Sheet for Interaction export
    Sheets("Data").Columns("W:AJ").Copy Sheets("Interactions").Range("C1")


End Sub

Sub ConvertDateFormat()
    Sheets("Interactions").Range("E3", "E50000").NumberFormat = "yyyymmddhhmmss"
End Sub

Sub ExportToCSV()
Dim dt As String

' Save Contacts File
    For i = 1 To Worksheets.Count
    If Worksheets(i).Name = "Contacts" Then
        exists = True
    End If
    Next i

    If exists Then

       DeleteEmptyColumns "Contacts"


        'Sheets("Contacts").Select
        'dt = Format(CStr(Now))
        dt = Format(Now(), "yyyymmddhhmmss")

        'filepart1 = "Bulk_Contacts_"

        fileSaveAsName = "Bulk_Contacts_" + dt

        'fileSaveAsName = Application.GetSaveAsFilename(fileSaveAsName)
        fileSaveAsName = Application.GetSaveAsFilename(InitialFileName:=fileSaveAsName, FileFilter:="csv Files (*.csv), *.csv")
        If fileSaveAsName = False Then
            Exit Sub
        End If

        'fileSaveAsName = fileSaveAsName + ".csv"

       ' ActiveWorkbook.SaveAs Filename:=fileSaveAsName, FileFormat:=xlUnicodeText, CreateBackup:=False
      ' ActiveWorkbook.Worksheets.s Filename:=fileSaveAsName, FileFormat:=xlUnicodeText, CreateBackup:=False

        Application.DisplayAlerts = False

        ThisWorkbook.Sheets("Contacts").Copy

        On Error GoTo unSuccessful
        ActiveWorkbook.SaveAs Filename:=fileSaveAsName, FileFormat:=xlCSV, CreateBackup:=True
        ActiveWorkbook.Close SaveChanges:=False
        Application.DisplayAlerts = True



    End If


' Save Interactions File
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "Interactions" Then
            exists = True
        End If
        Next i

        If exists Then
            Sheets("Interactions").Select

            fileSaveAsName = "Bulk_Interactions_" & dt
            fileSaveAsName = Application.GetSaveAsFilename(InitialFileName:=fileSaveAsName, FileFilter:="csv Files (*.csv), *.csv")
            If fileSaveAsName = False Then
                Exit Sub
            End If

            'fileSaveAsName = fileSaveAsName + ".csv"
           ' ActiveWorkbook.SaveAs Filename:=fileSaveAsName, FileFormat:=xlUnicodeText, CreateBackup:=False

            Application.DisplayAlerts = False

            ThisWorkbook.Sheets("Interactions").Copy

            On Error GoTo unSuccessful
            ActiveWorkbook.SaveAs Filename:=fileSaveAsName, FileFormat:=xlCSV, CreateBackup:=True
            ActiveWorkbook.Close SaveChanges:=False

            Application.DisplayAlerts = True
        End If

        'MsgBox "Files Successfully Prepared and Exported!"
        Exit Sub


unSuccessful:
            MsgBox Err.Description
            Exit Sub

End Sub

Sub DeleteSplitSheets()
' Check if Interactions sheet exists and delete if present.
    For i = 1 To Worksheets.Count
            If Worksheets(i).Name = "Interactions" Then
                exists = True
            End If
            Next i

            If exists Then
                Application.DisplayAlerts = False
                Sheets("Interactions").Delete
                Application.DisplayAlerts = True
            End If

' Check if Contacts sheet exists and delete if present.
    For i = 1 To Worksheets.Count
            If Worksheets(i).Name = "Contacts" Then
                exists = True
            End If
            Next i

            If exists Then
                Application.DisplayAlerts = False
                Sheets("Contacts").Delete
                Application.DisplayAlerts = True
            End If
End Sub

Sub DisplaySuccess()
    MsgBox "Files Successfully Prepared and Exported!"
End Sub


Sub DeleteEmptyColumns(SheetName As String)
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long
    Dim lastCol As Long

    Set ws = ThisWorkbook.Sheets(SheetName)
    lastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
    lastCol = lastCol + 1
   ' myCol = GetColumnLetter(lastCol)
    Dim vArr
    vArr = Split(Cells(1, lastCol).Address(True, False), "$")
    myCol = vArr(0)

    ws.Columns(myCol & ":XFD").Delete Shift:=xlToLeft
End Sub

Answer 1

全部，谢谢您的答复。 我发现了问题。 我正在执行列格式，而不是仅对已填充的行进行格式化，而是对所有行进行了格式化。 这导致多余的空白定界列。