從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