Excel-VBA 工作表拆分和保存以逗号分隔的许多空白列结束
Posted
技术标签:
【中文标题】Excel-VBA 工作表拆分和保存以逗号分隔的许多空白列结束【英文标题】:Excel-VBA sheet split and save ends up with many blank columns delimited by commas 【发布时间】:2018-02-05 16:24:28 【问题描述】:我是 excel-vba 的新手,能够成功地将某些列复制到新工作表中,并将新工作表另存为单独的 csv 文件,但是,当我在记事本中打开新创建的文件时,我可以看到大量额外的逗号代表很多额外的不必要的列。我在保存之前添加了另一个步骤来删除新创建的工作表中的列,但是仍然没有解决问题。
重申一下,我让用户在一张工作表上完成数据,然后在他们单击按钮后,将工作表拆分为两个新工作表,然后将每个新工作表保存为自己的 CSV 工作簿。然后这些在外部使用。新创建的 CSV 文件有过多的逗号分隔列,我的删除列 sub 仍然存在。
谢谢!克里斯
这是我的代码:
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
【问题讨论】:
您是否尝试将每个文件另存为 .xlsx 以验证是否出现了多余的逗号? 我刚刚试了一下,结果是一样的,额外的分隔列。 如果您可以显示原始输入的图像,它可能会很有用。只看代码,我没有看到任何明显的东西。 只是为了确定,您的源数据周围没有逗号? 删除 Sub SplitSheet(),并添加到每个复制粘贴... ".PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False" 【参考方案1】:所有,感谢您的回复。我发现了这个问题。我正在执行列格式,而不是只获取填充的行,我正在格式化所有行。这导致过多的空白分隔列。
【讨论】:
以上是关于Excel-VBA 工作表拆分和保存以逗号分隔的许多空白列结束的主要内容,如果未能解决你的问题,请参考以下文章
Oracle PL/SQL 程序在源表中拆分逗号分隔的数据并推送到目标表中