Это альтернативный подход к моему оригиналу в попытке улучшить производительность. В этом случае вместо использования Excel для создания CSV-файла код VBScript записывает CSV-файл напрямую, используя текстовый файл, созданный FileSystemObject. Я протестировал это с большим набором исходных данных, и, похоже, это немного быстрее, чем оригинал — около 40 секунд для 1500 строк. Открытие приложения 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
person
JohnRC
schedule
24.10.2017
