К примеру, есть у вас несколько десятков (или сотен) текстовых файлов с подобным содержимым:
(количество файлов, и количество строк данных в каждом файле не ограничено)

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)

• 34310 просмотров