用vbscript从xlsx中删除蓝色和空的单元格

我有一个VBScript将特定范围的行转换为CSV文件。
我的问题是它也复制空行，不需要蓝色的行。 如何在复制之前删除这些完整的空行或将它们从复制中排除？
我的代码：

Public Sub xlsToCsv() Const WorkingDir = "C:\Test\" Const xlCSV = 24 Const xlUp = -4162 Dim fso, SaveName, myFile Dim objExcel, objWorkbook, wsSource, wsTarget myFile = "source_file.xlsx" SaveName = "test.csv" With CreateObject("Scripting.FilesystemObject") If Not .FileExists(WorkingDir & myFile) Then MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled" WScript.Quit End If End With Set objExcel = CreateObject("Excel.Application") objExcel.Visible = False objExcel.DisplayAlerts = False Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile) Set wsSource = objWorkbook.Sheets(1) Set wsTarget = objWorkbook.Sheets.Add() With wsTarget .Cells(1,1).Value = "ID" .Cells(1,2).Value = "NAME" .Cells(1,3).Value = "DESC" End With With wsSource .Range("F7", .Range("F" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("A2") .Range("A7", .Range("A" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("B2") .Range("E7", .Range("E" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("C2") End With objWorkbook.SaveAs WorkingDir & SaveName, xlCSV objWorkbook.Close True Set objWorkbook = Nothing Set objExcel = Nothing Set fso = Nothing Set myFolder = Nothing End Sub call xlsToCsv() 

Answer 1

 Option explicit '// Define the blue color here dim ibluecolor: ibluecolor = 15652797 ' this is 40% Accent1 Public Sub xlsToCsv() Const WorkingDir = "C:\Test\" Const xlCSV = 24 Const xlUp = -4162 Dim fso, SaveName, myFile, myFolder Dim objExcel, objWorkbook, wsSource, wsTarget myFile = "source_file.xlsx" SaveName = "test.csv" With CreateObject("Scripting.FilesystemObject") If Not .FileExists(WorkingDir & myFile) Then MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled" WScript.Quit End If End With Set objExcel = CreateObject("Excel.Application") objExcel.Visible = False objExcel.DisplayAlerts = False Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile) Set wsSource = objWorkbook.Sheets(1) Set wsTarget = objWorkbook.Sheets.Add() With wsTarget .Cells(1,1).Value = "ID" .Cells(1,2).Value = "NAME" .Cells(1,3).Value = "DESC" End With dim Fcol, Acol, Ecol With wsSource set Fcol = .Range("F7", .Range("F" & .Rows.Count).End(xlUp)) set Acol = .Range("A7", .Range("A" & .Rows.Count).End(xlUp)) set Ecol = .Range("E7", .Range("E" & .Rows.Count).End(xlUp)) End With With wsTarget Fcol.Copy .Range("A2") Acol.Copy .Range("B2") Ecol.Copy .Range("C2") End With dim Frc, Arc, Erc Frc = Fcol.Rows.Count Arc = Acol.Rows.Count Erc = Ecol.Rows.Count dim rowcount rowcount = Max(Arc, Frc, Erc) dim ix with wsTarget for ix = rowcount + 1 to 2 step -1 if Len(.cells(ix,1))=0 and len(.cells(ix,2))=0 and len(.cells(ix,3))=0 then .rows(ix).delete '//Check for blue rows assuming all cells in the row have the same color elseif .cells(ix, 1).Interior.Color = iBlueColor then .rows(ix).delete end if next End With objWorkbook.SaveAs WorkingDir & SaveName, xlCSV objWorkbook.Close True Set objWorkbook = Nothing Set objExcel = Nothing Set fso = Nothing Set myFolder = Nothing End Sub call xlsToCsv() Function Max(v1, v2, v3) select case true case v1 => v2 and v1 => v3 Max = v1 case v2 => v3 Max = v2 case else Max = v3 end select end function 

Answer 2

这是我原创的另一种方法，旨在提高性能。 在这种情况下，VBScript代码不是使用Excel创buildcsv文件，而是使用由FileSystemObject创build的文本文件直接写入csv文件。 我用一组更大的源数据testing了它，它似乎比原来的要快得多 – 对于1500行大约需要40秒。 打开Excel应用程序仍然有一些开销（大约5-10秒），但是你可以做的事情不多。 如果绩效对你很重要，那么你可以做其他改进。

如果在电子表格中有数字值，则可能需要执行一些格式转换为适合csv输出的string值，因为Excel倾向于使用指数表示法来转换为文本的数字，这并不总是您想要的。 我也使用了引号和逗号分隔符，但是您可以对CSV输出使用不同的格式约定。 您可能需要更改WriteLine的使用，因为这会在最后一行之后追加一个CrLf，可能会将其解释为空白行。

 Option explicit '// Define the blue color here dim ibluecolor: ibluecolor = 15652797 ' this is 40% Accent1 msgbox "starting" call xlsToCsv() msgbox "finished" Public Sub xlsToCsv() Const WorkingDir = "C:\Test\" Const xlCSV = 24 Const xlUp = -4162 Dim fso, SaveName, myFile, myFolder Dim objExcel, objWorkbook, wsSource, wsTarget Dim oOutputFile myFile = "source_file.xlsx" SaveName = "test2.csv" With CreateObject("Scripting.FilesystemObject") '// Check that the input file exists If Not .FileExists(WorkingDir & myFile) Then MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled" WScript.Quit End If '// Create a text file to be the output csv file '// Overwrite vv False=ASCII format use True for Unicode format set oOutputFile = .CreateTextFile( WorkingDir & SaveName, True, False) End With Set objExcel = CreateObject("Excel.Application") objExcel.Visible = False objExcel.DisplayAlerts = False Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile) Set wsSource = objWorkbook.Sheets(1) oOutputFile.WriteLine """ID"",""NAME"",""DESC""" '// Get the three column ranges, starting at cells in row 7 dim Fcol, Acol, Ecol With wsSource set Fcol = .Range("F7", .Range("F" & .Rows.Count).End(xlUp)) set Acol = .Range("A7", .Range("A" & .Rows.Count).End(xlUp)) set Ecol = .Range("E7", .Range("E" & .Rows.Count).End(xlUp)) End With '// Get the number of rows in each column dim Frc, Arc, Erc Frc = Fcol.Rows.Count Arc = Acol.Rows.Count Erc = Ecol.Rows.Count '// Rowcount is the max row of the three dim rowcount rowcount = Max(Arc, Frc, Erc) dim AVal, FVal, EVal dim ix for ix = 1 to rowcount '// Note - row 1 of each column is actually row 7 in the workbook AVal = REPLACE(ACol.Cells(ix, 1), """", """""") EVal = REPLACE(ECol.Cells(ix, 1), """", """""") FVal = REPLACE(FCol.Cells(ix, 1), """", """""") '// Check for an empty row if Len(AVal)=0 and len(EVal)=0 and len(FVal)=0 then '// skip this row '// Check for a blue row elseif ACol.cells(ix,1).Interior.Color = iBlueColor then '// skip this row else '// Write the line to the csv file oOutputFile.WriteLine """" & FVal & """,""" & AVal & """,""" & EVal & """" end if next '// Close the output file oOutputFile.Close '// Close the workbook objWorkbook.Close True objExcel.Quit '// Clean up Set oOutputFile = Nothing Set objWorkbook = Nothing Set objExcel = Nothing Set fso = Nothing Set myFolder = Nothing End Sub Function Max(v1, v2, v3) select case true case v1 >= v2 and v1 >= v3 Max = v1 case v2 >= v3 Max = v2 case else Max = v3 end select end function