VBA 用于在删除空白行或 "blank" 但包含公式的行后将工作表作为 CSV 文件导出到特定位置的脚本
VBA script to export sheets as CSV files to a specific location after deleting rows that are blank or "blank" but contain formula
我正在编写一个 VBA 脚本,以允许从 Excel 工作簿中操作和导出许多工作表作为 csv 文件。我希望能够将指定工作表的列表作为 csv 文件导出到可以选择的保存位置,此外,特定列中空白但可能包含公式的任何单元格都需要完整行已删除。下面的脚本是我目前拥有的,它似乎在一定程度上起作用,但存在三个主要问题:
如果 A 列中的单元格确实为空白,即不包含公式,则下面的行将删除行,但如果存在公式则不起作用:Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
循环遍历工作表虽然不整洁但很实用,有没有办法使用命名工作表列表使脚本更简洁?
理想情况下,保存位置也可以从选择文件目录对话框中选择。关于如何实现这一点有什么建议吗?
非常感谢。
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
我认为您正在寻找这样的东西:
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
我正在编写一个 VBA 脚本,以允许从 Excel 工作簿中操作和导出许多工作表作为 csv 文件。我希望能够将指定工作表的列表作为 csv 文件导出到可以选择的保存位置,此外,特定列中空白但可能包含公式的任何单元格都需要完整行已删除。下面的脚本是我目前拥有的,它似乎在一定程度上起作用,但存在三个主要问题:
如果 A 列中的单元格确实为空白,即不包含公式,则下面的行将删除行,但如果存在公式则不起作用:
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
循环遍历工作表虽然不整洁但很实用,有没有办法使用命名工作表列表使脚本更简洁?
理想情况下,保存位置也可以从选择文件目录对话框中选择。关于如何实现这一点有什么建议吗?
非常感谢。
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
我认为您正在寻找这样的东西:
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