从xlsx删除蓝色和空单元格与vbscript

Question

我有一个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创建csv文件，而是使用由FileSystemObject创建的文本文件直接写入csv文件。我用一组更大的源数据测试了它，它似乎比原来的要快得多 - 对于1500行大约需要40秒。打开Excel应用程序仍有一些开销（大约5-10秒），但您可以做的不多。如果绩效对你很重要，那么你可以做其他改进。

如果在电子表格中有数字值，则可能需要执行一些格式转换为适用于csv输出的字符串值，因为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 v  v 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