使用vbscript从xlsx中删除蓝色和空单元格

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

这是我原创的一种替代方法，旨在提高性能。在这种情况下，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