|
К примеру, есть у вас несколько десятков (или сотен) текстовых файлов с подобным содержимым:
(количество файлов, и количество строк данных в каждом файле не ограничено)
1c04;1J0-698-151-G;1 комплект тормозных накладок;1J0698151G;1J0698151G;5;1
1c04;1H0698151A;Тормозные колодки;1H0698151A;1H0698151A;1;1
1c04;1K0-698-151-B;Тормозные колодки;1K0698151B;1K0698151B;2;1
А надо из всего этого сформировать табличку в Excel - приблизительно такого вида:
На помощь придёт функция DATfolder2Array
Sub ПримерИспользованияФункции_DATfolder2Array()
Папка = "D:\Проекты\DATs\" ' папка, в которой будет производиться поиск файлов DAT для обработки
Dim ErrorsArray ' пустой массив для ошибок
' считываем данные из все файлов .DAT в папке в двумерный массив
DataArr = DATfolder2Array(Папка, 7, "1,2,4,5", ErrorsArray)
' результаты выводим на листы "errors" и "result" (они должны существовать)
Array2worksheet Worksheets("errors"), ErrorsArray, _
Array("Имя файла", "Номер строки", "Данные из строки")
Array2worksheet Worksheets("result"), DataArr, _
Array("Ячейка", "Штрих-Код", "Наименование", "код 1С", "код произв.", "кол-во", "счетовод")
End Sub
Код функции DATfolder2Array:
Function DATfolder2Array(ByVal FolderPath$, ByVal ColumnsCount As Long, _
ByVal TextColumns$, ByRef ErrorsArr) As Variant
' получает путь FolderPath$ к папке с DAT-файлами
' считывает из файлов все строки, в которых число записей в строке равно ColumnsCount
' остальные (неподходящие) строки отправляет в массив ErrorsArr
' (столбцы ErrorsArr: 1-имя файла, 2 - номер строки, 3 - данные)
' в переменной TextColumns$ через запятую перечислены номера ТЕКСТОВЫХ столбцов
' Возвращает двумерный массив размером N*ColumnsCount
ReDim ErrorsArr(1 To 1000, 1 To ColumnsCount + 2)
On Error Resume Next
Dim coll As New Collection, filename
filename = Dir(FolderPath$ & "*.dat")
While filename <> ""
coll.Add filename ' считываем в колекцию coll нужные имена файлов
filename = Dir
Wend
Dim newtxt As String, ro As String, errIndex As Long
For Each filename In coll
Application.StatusBar = "Обрабатывается файл: " & filename
newtxt = ReadTXTfile(FolderPath$ & filename)
tempArr = "": tempArr = Split(newtxt, vbNewLine)
For i = LBound(tempArr) To UBound(tempArr)
ro = tempArr(i): ro = Replace(ro, vbTab, ";")
If UBound(Split(ro, ";")) <> ColumnsCount - 1 And Len(Trim(ro)) > 0 Then
tempArr(i) = "": errIndex = errIndex + 1
ErrorsArr(errIndex, 1) = filename
ErrorsArr(errIndex, 2) = "Строка " & i + 1
ErrorsArr(errIndex, 3) = ro
End If
Next i
newtxt = Join(tempArr, vbNewLine)
txt = txt & newtxt & vbNewLine: DoEvents
Next
While InStr(1, txt, vbNewLine & vbNewLine) > 0
txt = Replace(txt, vbNewLine & vbNewLine, vbNewLine)
Wend
txt = Replace(txt, vbTab, ";"): tempArr = Split(txt, vbNewLine)
ReDim newArr(1 To UBound(tempArr), 1 To ColumnsCount)
For i = LBound(tempArr) To UBound(tempArr)
roArr = "": roArr = Split(tempArr(i), ";")
For j = 1 To ColumnsCount
newArr(i + 1, j) = roArr(j - 1)
If "," & TextColumns$ & "," Like "*," & j & ",*" Then
newArr(i + 1, j) = "'" & newArr(i + 1, j)
End If
Next j
Next i
DATfolder2Array = newArr
Application.StatusBar = False
End Function
Код вспомогательной функции Array2worksheet можно найти на странице http://excelvba.ru/code/Array2worksheet (Перенос двумерного массива на лист Excel)
|
