delete blue and empty cells from xlsx with vbscript - excel

Question

I've got a vbscript that converts a specific range of rows to a csv file.
My problem is it also copies empty rows and not needed blue rows. How can I delete this complete empty rows before copying or exclude them from copying?
My 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

This is an alternative approach to my original in an attempt to improve performance. In this case, instead of using Excel to create the csv file, the VBScript code writes the csv file directly using a text file created by FileSystemObject. I have tested this with a larger set of source data and it seems to be quite a bit quicker than the original - about 40 seconds for 1500 rows. There is still an overhead of opening the Excel application (about 5-10 seconds) but there's not much you can do about that. If performance is important to you there may be other improvements that you could do.
If you have numeric values in the spreadsheet, you may need to do some formatting to convert to string values suitable for csv output, because Excel tends to use exponential notation for numbers converted to text, which is not always what you want. I have also used quotation marks and comma separators but you could use different formatting conventions for your CSV output. You may want to change the use of WriteLine because this appends a CrLf after the last line, which might be interpreted downstream as a blank row.
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