Supprimer les cellules bleues et vides de xlsx avec vbscript

Question

J'ai un vbscript qui convertit une plage spécifique de lignes en un fichier csv.
Mon problème est qu'il copie aussi des lignes vides et des lignes bleues inutiles. Comment puis-je supprimer ces lignes vides complètes avant de les copier ou les exclure de la copie?
Mon code:

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

Ceci est une approche alternative à mon original pour tenter d'améliorer les performances. Dans ce cas, au lieu d'utiliser Excel pour créer le fichier csv, le code VBScript écrit le fichier csv directement à l'aide d'un fichier texte créé par FileSystemObject. J'ai testé cela avec un plus grand ensemble de données source et il semble être un peu plus rapide que l'original - environ 40 secondes pour 1500 lignes. Il y a encore un temps d'ouverture de l'application Excel (environ 5-10 secondes) mais il n'y a pas grand chose à faire à ce sujet. Si la performance est importante pour vous, il peut y avoir d'autres améliorations que vous pourriez faire. Si vous avez des valeurs numériques dans la feuille de calcul, vous devrez peut-être effectuer une mise en forme pour convertir en valeurs de chaîne appropriées pour la sortie csv, car Excel utilise la notation exponentielle pour les nombres convertis en texte, ce qui n'est pas toujours le cas. . J'ai également utilisé des guillemets et des séparateurs de virgules mais vous pouvez utiliser différentes conventions de mise en forme pour votre sortie CSV. Vous pouvez changer l'utilisation de WriteLine car cela ajoute un CrLf après la dernière ligne, qui pourrait être interprétée en aval comme une ligne vide.

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