Batya
|
 Posted: Mon Dec 14, 2009 17:23 Post subject: |
 |
|
Andrey_A
Недавно пришлось делать для себя нечто похожее.
После дорабатывания под твою задачу получился следующий vbs:
| Code: | '=============================================================
' Создание txt-файла из xls-файла
' Параметры скрипта:
' {excel-файл} {txt-файл}
'=============================================================
Option Explicit
'=============== Изменяемые параметры ========================
Const ReplNewLine = "|" 'Символ для замены переносов строк
Const SheetName = "Test" 'Имя листа для сохранения
'=============================================================
Dim FSO, XlsFile, objXL, TxtFile
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objXL = CreateObject("Excel.Application")
CheckParams
On Error Resume Next
objXL.DisplayAlerts = False
objXL.Workbooks.Open XlsFile
If Err.Number > 0 Then Quit
Main
If Err.Number > 0 Then MsgBox Err.Description, 0, "Xls2Txt"
On Error Goto 0
objXL.Quit()
WScript.Sleep 1000
On Error Resume Next
ReplInTxtFile
On Error Goto 0
Quit
'===== Процедуры и функции ===================================
'Основная процедура
Sub Main
'Переходим на нужный лист
objXL.Sheets(SheetName).Select
'Убираем лишние данные
objXL.Range("A1", "A65536" ).Delete
objXL.Range("E1", "IV65536").Delete
'Заменяем переносы строк в ячейках
objXL.Range("A1", "IV65536").Replace Chr(10), ReplNewLine
objXL.Range("A1", "IV65536").Replace Chr(13), ReplNewLine
objXL.Range("A1", "IV65536").Replace ReplNewLine & ReplNewLine, ReplNewLine
If FSO.FileExists(TxtFile) Then FSO.DeleteFile TxtFile, True
'Сохранение результатов
objXL.Application.ActiveWorkbook.SaveAs TxtFile, -4158
End Sub
'Дополнительная обработка итогового txt-файла
Sub ReplInTxtFile
Dim lText
lText = FSO.OpenTextFile(TxtFile).ReadAll
lText = Replace(lText, ReplNewLine & vbTab, vbTab)
FSO.OpenTextFile(TxtFile, 2).Write lText
End Sub
'Проверка входных параметров
Sub CheckParams
With WScript
If .Arguments.Count < 2 Then Quit
XlsFile = .Arguments(0)
If Not FSO.FileExists(XlsFile) Then Quit
TxtFile = .Arguments(1)
End With
End Sub
'Выход
Sub Quit
Set objXL = Nothing
Set FSO = Nothing
WScript.Quit
End Sub |
Мне для своей задачи нужно было еще удалить переносы строк в ячейках. Здесть тоже оставил, иначе строчки поедут.
_________________
Нет, я не сплю. Я просто медленно моргаю. |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
