xlsxの青と空のセルをvbscriptで削除する

Question

特定の範囲の行をcsvファイルに変換するvbscriptがあります。
私の問題は、空の行をコピーし、青い行を必要としないということです。この完全な空の行をコピーする前に削除するにはどうしたらいいですか？
マイコード：

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

これは、パフォーマンスを改善するための試みで、私の元に別のアプローチです。この場合、Excelを使用してcsvファイルを作成する代わりに、VBScriptコードはFileSystemObjectによって作成されたテキストファイルを使用してcsvファイルを直接書き込みます。私はこれをより大きなソースデータセットでテストしました。これは元のデータよりもかなり速いと思われます。つまり、1500行で約40秒です。まだExcelアプリケーションを開くのにかかるオーバーヘッドがありますが（約5-10秒）、それについてはあまりできません。パフォーマンスが重要な場合は、他にも改善があるかもしれません。

スプレッドシートに数値がある場合、Excelはテキストに変換された数値に指数表記を使用する傾向があるため、csv出力に適した文字列値に変換するためには何らかのフォーマットを行う必要があります。引用符とカンマ区切りも使用していますが、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