delete blue and empty cells from xlsx with vbscript

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()

You can autofilter for blank OR blue rows and delete them. And then make your CSV. — danieltakeshi, Oct 16 '17 at 11:21
I need it not only for cells. I need to the delete a row if a complete row is empty. Can I filter for that? How can I filter for blue cells? — nolags, Oct 16 '17 at 11:24
Refer to the following questions: to [filter for colored](https://stackoverflow.com/a/35982191/7690982) and [delete blank row](https://stackoverflow.com/a/22542280/7690982) or [VBA code to delete a row based on a non empty cell in a column](https://stackoverflow.com/a/26610471/7690982) — danieltakeshi, Oct 16 '17 at 11:34
tried this command "wsSource.Range("A:F").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete" ended with the error code 800A03EC - the special cells property of the range object couldnt be assigned. — nolags, Oct 16 '17 at 12:02
It works for me, without this error, refer to [this](https://stackoverflow.com/a/18898171/7690982). And note that you are deleting the entire Row, so if you have blank values in row A and non blank in F, you will lose the values in F — danieltakeshi, Oct 16 '17 at 12:09
I want to proof if the complete row is empty and then delete the complete row. — nolags, Oct 16 '17 at 12:19

JohnRC · Answer 1 · 2017-10-16T15:30:34.957

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

this excel file has 1400 lines. Your solution works but needs about 6 minutes to finish. Do you know something faster? — nolags, Oct 23 '17 at 08:02
Try putting `Appplication.Calculation=xlCalculationManual` and `Application.Screenupdating=False` before the loop, then reset them to `xlCalculationAutomatic` and `True` after the loop. — JohnRC, Oct 23 '17 at 09:27
Sorry- my note above should have said `ObjExcel` instead of `Application` - I guess that's what you tried? — JohnRC, Oct 24 '17 at 14:03
i already changed it to objExcel because with Application it didnt work. But it still lasts about 6 minutes .. is that the common time something like this lasts or is there a faster way — nolags, Oct 24 '17 at 14:40

score 0 · Answer 2 · answered Oct 24 '17 at 15:18

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

delete blue and empty cells from xlsx with vbscript

2 Answers2