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