Есть следующая задача. Из данных в таблице необходимо сделать текстовые файлы ANSI 1251 с расширением .qvd (пример таблицы приложен в реальной таблице более 12 тыс. записей). Из каждой строки таблицы необходимо сформировать отдельный файл с нумерацией 99900001, где последние 5 цифр номер строки таблицы (причем именно 5 т.е. необходимо дополнять впереди нулями если номер строки 1,2,3 или 4 цифры). Файл состоит из 2-х строк первая заголовок (который всегда одинаковый) во второй строке все данные постоянные кроме несколько раз используемых ФИО из таблицы, причем Фамилия Имя и Отчество отдельно (т.е. необходимо ФИО из таблицы разделить на 3 реквизита, можно это сделать предварительно в самой таблице), даты рождения в формате ДД.ММ.ГГГГ, даты рождения в цифровом формате (колонка C) и последних реквизитов в строке §52=99900003.qvd§55=0003, где после §52= имя формируемого файла, а после §55= 4 последние цифры от имени файла. Как видно из содержимого файла .qvd, это SQL который будет обработан и получены файлы ответа. И соответственно обратная задача необходимо данные из файлов ответа импортировать в Excel. Файлы сложу в одну папку и только те, в которых есть данные, т.е. необходимо обработать все файлы в папке. Файл ответа состоит из 2 и более строк. Первая строка заголовок, который обрабатывать не нужно, а вторая и возможно больше состоит из § - разделитель 1= - поле далее значение и следующий разделитель. Набор полей не постоянный, т.е. если у одной записи поле 5 пустое §5= в файле не будет, а у другой записи поле не пусто §5= будет присутствовать в файле. Все поля обрабатывать нет необходимости, а необходимо сделать что-то типа значение после §19= записать в колонку A если §19= нет колонку оставить пустую и т.д. набор обрабатываемых полей определю сам. Если в файле более 2 строк каждая строчка обрабатывается в новую строку таблицы. И так из всех файлов каждая строка новая добавляемая строка в таблицу. С VBA не знаком вообще но есть опыт программирования в других языках поэтому просьба в примере добавить комментарии, чтобы я мог самостоятельно допилить.
Есть следующая задача. Из данных в таблице необходимо сделать текстовые файлы ANSI 1251 с расширением .qvd (пример таблицы приложен в реальной таблице более 12 тыс. записей). Из каждой строки таблицы необходимо сформировать отдельный файл с нумерацией 99900001, где последние 5 цифр номер строки таблицы (причем именно 5 т.е. необходимо дополнять впереди нулями если номер строки 1,2,3 или 4 цифры). Файл состоит из 2-х строк первая заголовок (который всегда одинаковый) во второй строке все данные постоянные кроме несколько раз используемых ФИО из таблицы, причем Фамилия Имя и Отчество отдельно (т.е. необходимо ФИО из таблицы разделить на 3 реквизита, можно это сделать предварительно в самой таблице), даты рождения в формате ДД.ММ.ГГГГ, даты рождения в цифровом формате (колонка C) и последних реквизитов в строке §52=99900003.qvd§55=0003, где после §52= имя формируемого файла, а после §55= 4 последние цифры от имени файла. Как видно из содержимого файла .qvd, это SQL который будет обработан и получены файлы ответа. И соответственно обратная задача необходимо данные из файлов ответа импортировать в Excel. Файлы сложу в одну папку и только те, в которых есть данные, т.е. необходимо обработать все файлы в папке. Файл ответа состоит из 2 и более строк. Первая строка заголовок, который обрабатывать не нужно, а вторая и возможно больше состоит из § - разделитель 1= - поле далее значение и следующий разделитель. Набор полей не постоянный, т.е. если у одной записи поле 5 пустое §5= в файле не будет, а у другой записи поле не пусто §5= будет присутствовать в файле. Все поля обрабатывать нет необходимости, а необходимо сделать что-то типа значение после §19= записать в колонку A если §19= нет колонку оставить пустую и т.д. набор обрабатываемых полей определю сам. Если в файле более 2 строк каждая строчка обрабатывается в новую строку таблицы. И так из всех файлов каждая строка новая добавляемая строка в таблицу. С VBA не знаком вообще но есть опыт программирования в других языках поэтому просьба в примере добавить комментарии, чтобы я мог самостоятельно допилить.DmitriyGen
a = Split(CreateObject("Scripting.FileSystemObject").Getfile("c:\Users\Igor\Downloads\99900386.rvd").OpenasTextStream(1).ReadAll, vbLf) For i = 1 To UBound(a) b = Split(a(i), "§") If UBound(b) > 0 Then For ii = 1 To UBound(b) Cells(ind, --Split(b(ii), "=")(0)) = Split(b(ii), "=")(1) Next End If Next
End Sub
[/vba]
Заготовка на вторую задачу: [vba]
Код
Sub tt() Dim a, b, i&, ii& Dim ind&: ind = 2
a = Split(CreateObject("Scripting.FileSystemObject").Getfile("c:\Users\Igor\Downloads\99900386.rvd").OpenasTextStream(1).ReadAll, vbLf) For i = 1 To UBound(a) b = Split(a(i), "§") If UBound(b) > 0 Then For ii = 1 To UBound(b) Cells(ind, --Split(b(ii), "=")(0)) = Split(b(ii), "=")(1) Next End If Next
Hugo, а как обработать все файлы в папке если их кол-во заранее не известно. Как уже писал ранее строк в файле может быть несколко первая пропускается а последующие обрабатываються каждая с строка это новая строка таблицы. И так из всех файлов в одну таблицу все строки исключая первые. И импортировать не всю строку а по условию если есть поле §19= его значение записать в столбец 1 и т.д.
Hugo, а как обработать все файлы в папке если их кол-во заранее не известно. Как уже писал ранее строк в файле может быть несколко первая пропускается а последующие обрабатываються каждая с строка это новая строка таблицы. И так из всех файлов в одну таблицу все строки исключая первые. И импортировать не всю строку а по условию если есть поле §19= его значение записать в столбец 1 и т.д.DmitriyGen
Почти со всем разобрался остались две проблемы если в файле ответа более двух строк то в таблицу попадает только последняя строка файла. Видимо счетчик строк не там ставлю. И не могу преобразовать из текста ГГГГММДД в дату Cdate выдает ошибку. [vba]
Код
Sub MyExp() Dim a, b, i&, ii& Dim ind&: ind = 1
Set fso = CreateObject("Scripting.FileSystemObject") Set TheFolder = fso.GetFolder("g:\222\") Set TheFiles = TheFolder.Files
For Each AFile In TheFiles If UCase(fso.GetExtensionName(AFile.Path)) = "RVD" Then Set ts = fso.OpenTextFile(AFile.Path, 1) ts.Close a = Split(fso.Getfile(AFile.Path).OpenasTextStream(1).ReadAll, vbLf)
For i = 1 To UBound(a) b = Split(a(i), "§")
If UBound(b) > 0 Then For ii = 1 To UBound(b) ' MsgBox "111: " & b(ii) If Left(b(ii), 2) = "3=" Then Cells(ind, 5) = Split(b(ii), "=")(1) End If If Left(b(ii), 2) = "5=" Then Cells(ind, 6) = Split(b(ii), "=")(1) End If If Left(b(ii), 3) = "19=" Then Cells(ind, 1) = Split(b(ii), "=")(1) End If If Left(b(ii), 3) = "20=" Then Cells(ind, 2) = Split(b(ii), "=")(1) End If If Left(b(ii), 3) = "21=" Then Cells(ind, 3) = Split(b(ii), "=")(1) End If If Left(b(ii), 3) = "25=" Then Cells(ind, 4) = Split(b(ii), "=")(1) End If If Left(b(ii), 4) = "134=" Then Cells(ind, 7) = Split(b(ii), "=")(1) End If If Left(b(ii), 4) = "135=" Then Cells(ind, 8) = Split(b(ii), "=")(1) End If Next End If Next End If ind = ind + 1 Next End Sub
[/vba]
Почти со всем разобрался остались две проблемы если в файле ответа более двух строк то в таблицу попадает только последняя строка файла. Видимо счетчик строк не там ставлю. И не могу преобразовать из текста ГГГГММДД в дату Cdate выдает ошибку. [vba]
Код
Sub MyExp() Dim a, b, i&, ii& Dim ind&: ind = 1
Set fso = CreateObject("Scripting.FileSystemObject") Set TheFolder = fso.GetFolder("g:\222\") Set TheFiles = TheFolder.Files
For Each AFile In TheFiles If UCase(fso.GetExtensionName(AFile.Path)) = "RVD" Then Set ts = fso.OpenTextFile(AFile.Path, 1) ts.Close a = Split(fso.Getfile(AFile.Path).OpenasTextStream(1).ReadAll, vbLf)
For i = 1 To UBound(a) b = Split(a(i), "§")
If UBound(b) > 0 Then For ii = 1 To UBound(b) ' MsgBox "111: " & b(ii) If Left(b(ii), 2) = "3=" Then Cells(ind, 5) = Split(b(ii), "=")(1) End If If Left(b(ii), 2) = "5=" Then Cells(ind, 6) = Split(b(ii), "=")(1) End If If Left(b(ii), 3) = "19=" Then Cells(ind, 1) = Split(b(ii), "=")(1) End If If Left(b(ii), 3) = "20=" Then Cells(ind, 2) = Split(b(ii), "=")(1) End If If Left(b(ii), 3) = "21=" Then Cells(ind, 3) = Split(b(ii), "=")(1) End If If Left(b(ii), 3) = "25=" Then Cells(ind, 4) = Split(b(ii), "=")(1) End If If Left(b(ii), 4) = "134=" Then Cells(ind, 7) = Split(b(ii), "=")(1) End If If Left(b(ii), 4) = "135=" Then Cells(ind, 8) = Split(b(ii), "=")(1) End If Next End If Next End If ind = ind + 1 Next End Sub
1 строка - на форуме полно кодов перебора файлов, берите и работайте. 2 строка - сделал 3 строка - см. 1 строка 4 строка - сделал, но только почему 19в1? Сделал 19в19, так логичнее Ведь не сделано "набор обрабатываемых полей определю сам." Когда будет список соответствий - его можно подключить в процесс раскладки. Я бы делал через словарь, но можно делать и иначе, медленнее.
1 строка - на форуме полно кодов перебора файлов, берите и работайте. 2 строка - сделал 3 строка - см. 1 строка 4 строка - сделал, но только почему 19в1? Сделал 19в19, так логичнее Ведь не сделано "набор обрабатываемых полей определю сам." Когда будет список соответствий - его можно подключить в процесс раскладки. Я бы делал через словарь, но можно делать и иначе, медленнее.Hugo
Перебор файлов вижу уже есть. Да, счётчик строк не там (а я вообще про него забыл) - ставьте его увеличение сразу после If UBound(b) > 0 Then Т.е. при обработке очередной строки текста, которую есть смысл обрабатывать (там в конце пустая строка, а вдруг могу попасться и без "§") увеличиваем счётчик строк. Ещё замечание - проверять If Left(b(ii), 2) = "3=" Then очень расточительно по всем ресурсам - и по написанию кода (сколько там вариантов?) и по нагрузке на процессор (сколько проверок будете делать на каждом шаге).
Перебор файлов вижу уже есть. Да, счётчик строк не там (а я вообще про него забыл) - ставьте его увеличение сразу после If UBound(b) > 0 Then Т.е. при обработке очередной строки текста, которую есть смысл обрабатывать (там в конце пустая строка, а вдруг могу попасться и без "§") увеличиваем счётчик строк. Ещё замечание - проверять If Left(b(ii), 2) = "3=" Then очень расточительно по всем ресурсам - и по написанию кода (сколько там вариантов?) и по нагрузке на процессор (сколько проверок будете делать на каждом шаге).Hugo
Конечно select case лучше - в Вашем варианте проверки идут до конца, с select case только пока не найдётся искомое. И код проще. А как выбрать число до "=" я ведь выше показал: --Split(b(ii), "=")(0) Вот далее ищите его в списке соответствий, получаете нужный столбец.
Конечно select case лучше - в Вашем варианте проверки идут до конца, с select case только пока не найдётся искомое. И код проще. А как выбрать число до "=" я ведь выше показал: --Split(b(ii), "=")(0) Вот далее ищите его в списке соответствий, получаете нужный столбец.Hugo
With CreateObject("scripting.dictionary") For i = 0 To UBound(sp1): .Item(sp1(i)) = sp2(i): Next
a = Split(CreateObject("Scripting.FileSystemObject").Getfile("c:\Users\Igor\Downloads\99900386.rvd").OpenasTextStream(1).ReadAll, vbLf)
For i = 1 To UBound(a) b = Split(a(i), "§") If UBound(b) > 0 Then ind = ind + 1 For ii = 1 To UBound(b) t = Split(b(ii), "=")(0) If .exists(t) Then Cells(ind, --.Item(t)) = Split(b(ii), "=")(1) Next End If Next
End With
End Sub
[/vba]
Вот вариант с списком соответствия в словаре (мой первый доработанный, под Ваш подгонять некогда, убегаю): [vba]
With CreateObject("scripting.dictionary") For i = 0 To UBound(sp1): .Item(sp1(i)) = sp2(i): Next
a = Split(CreateObject("Scripting.FileSystemObject").Getfile("c:\Users\Igor\Downloads\99900386.rvd").OpenasTextStream(1).ReadAll, vbLf)
For i = 1 To UBound(a) b = Split(a(i), "§") If UBound(b) > 0 Then ind = ind + 1 For ii = 1 To UBound(b) t = Split(b(ii), "=")(0) If .exists(t) Then Cells(ind, --.Item(t)) = Split(b(ii), "=")(1) Next End If Next
Set objRegExp = CreateObject("VBScript.RegExp") Set fso = CreateObject("Scripting.FileSystemObject") Set TheFolder = fso.GetFolder(ThisWorkbook.Path) Set TheFiles = TheFolder.Files
For Each AFile In TheFolder.Files If LCase$(fso.GetExtensionName(AFile.Name)) = "rvd" Then Set TextStream = AFile.OpenAsTextStream(1) stmp = TextStream.ReadAll TextStream.Close arrTmp = Split(stmp, vbLf) With ThisWorkbook.Sheets(3) For i = 1 To UBound(arrTmp) If Len(arrPat(i)) Then lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 For j = LBound(arrPat) To UBound(arrPat) objRegExp.Pattern = "§" & arrPat(j) & "=(.*?)?§" If objRegExp.Test(arrTmp(i)) Then If j = 3 Or j = 5 Then sDate = objRegExp.Execute(arrTmp(i))(0).submatches(0) sDate = Mid$(sDate, 7, 2) & "." & Mid$(sDate, 5, 2) & "." & Mid$(sDate, 1, 4) ' .Cells(lr, arrCell(j)) = sDate ' текст .Cells(lr, arrCell(j)) = CDate(sDate) ' дата Else .Cells(lr, arrCell(j)) = objRegExp.Execute(arrTmp(i))(0).submatches(0) End If End If Next End If Next End With End If Next End Sub
[/vba]
[vba]
Код
Sub Мяв()
Dim fso As Object, TheFolder As Object, AFile As Object, TextStream As Object Dim objRegExp As Object Dim arrCell(), arrPat(), arrTmp Dim i&, j&
Set objRegExp = CreateObject("VBScript.RegExp") Set fso = CreateObject("Scripting.FileSystemObject") Set TheFolder = fso.GetFolder(ThisWorkbook.Path) Set TheFiles = TheFolder.Files
For Each AFile In TheFolder.Files If LCase$(fso.GetExtensionName(AFile.Name)) = "rvd" Then Set TextStream = AFile.OpenAsTextStream(1) stmp = TextStream.ReadAll TextStream.Close arrTmp = Split(stmp, vbLf) With ThisWorkbook.Sheets(3) For i = 1 To UBound(arrTmp) If Len(arrPat(i)) Then lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 For j = LBound(arrPat) To UBound(arrPat) objRegExp.Pattern = "§" & arrPat(j) & "=(.*?)?§" If objRegExp.Test(arrTmp(i)) Then If j = 3 Or j = 5 Then sDate = objRegExp.Execute(arrTmp(i))(0).submatches(0) sDate = Mid$(sDate, 7, 2) & "." & Mid$(sDate, 5, 2) & "." & Mid$(sDate, 1, 4) ' .Cells(lr, arrCell(j)) = sDate ' текст .Cells(lr, arrCell(j)) = CDate(sDate) ' дата Else .Cells(lr, arrCell(j)) = objRegExp.Execute(arrTmp(i))(0).submatches(0) End If End If Next End If Next End With End If Next End Sub
Set fso = CreateObject("Scripting.FileSystemObject") Set TheFolder = fso.GetFolder("g:\222\") Set TheFiles = TheFolder.Files
For Each AFile In TheFiles If UCase(fso.GetExtensionName(AFile.Path)) = "RVD" Then Set ts = fso.OpenTextFile(AFile.Path, 1) ts.Close
For i = 0 To UBound(sp1): .Item(sp1(i)) = sp2(i): Next
a = Split(fso.Getfile(AFile.Path).OpenasTextStream(1).ReadAll, vbLf)
For i = 1 To UBound(a) b = Split(a(i), "§") If UBound(b) > 0 Then ind = ind + 1 For ii = 1 To UBound(b) t = Split(b(ii), "=")(0) ' MsgBox "111: " & t If .exists(t) Then Cells(ind, --.Item(t)) = Split(b(ii), "=")(1) If t = "5" Then Cells(ind, --.Item(t)) = Right(Split(b(ii), "=")(1), 2) & "." & Mid(Split(b(ii), "=")(1), 5, 2) & "." & Left(Split(b(ii), "=")(1), 4) If t = "25" Then Cells(ind, --.Item(t)) = Right(Split(b(ii), "=")(1), 2) & "." & Mid(Split(b(ii), "=")(1), 5, 2) & "." & Left(Split(b(ii), "=")(1), 4) Next End If Next End If Next End With
End Sub
[/vba] Вроде все работает.
Всем огромное спасибо за помощь. Вот что у меня в итоге получилось. [vba]
Код
Sub MyExp() Dim a, b, i&, ii&, t$ Dim ind&: ind = 0 Dim sp1, sp2
Set fso = CreateObject("Scripting.FileSystemObject") Set TheFolder = fso.GetFolder("g:\222\") Set TheFiles = TheFolder.Files
For Each AFile In TheFiles If UCase(fso.GetExtensionName(AFile.Path)) = "RVD" Then Set ts = fso.OpenTextFile(AFile.Path, 1) ts.Close
For i = 0 To UBound(sp1): .Item(sp1(i)) = sp2(i): Next
a = Split(fso.Getfile(AFile.Path).OpenasTextStream(1).ReadAll, vbLf)
For i = 1 To UBound(a) b = Split(a(i), "§") If UBound(b) > 0 Then ind = ind + 1 For ii = 1 To UBound(b) t = Split(b(ii), "=")(0) ' MsgBox "111: " & t If .exists(t) Then Cells(ind, --.Item(t)) = Split(b(ii), "=")(1) If t = "5" Then Cells(ind, --.Item(t)) = Right(Split(b(ii), "=")(1), 2) & "." & Mid(Split(b(ii), "=")(1), 5, 2) & "." & Left(Split(b(ii), "=")(1), 4) If t = "25" Then Cells(ind, --.Item(t)) = Right(Split(b(ii), "=")(1), 2) & "." & Mid(Split(b(ii), "=")(1), 5, 2) & "." & Left(Split(b(ii), "=")(1), 4) Next End If Next End If Next End With
Да, что-то я там с сплитом зря связался, сразу делать array лучше. Только первый массив делать из чисел текстом, второй из чисел, т.к. ключ нужен текстом, а номер столбца числом - тогда отпадают лишние преобразования в дальнейшем. И проверки на t = "5" и t ="25" целесообразно поместить внутрь проверки на наличие в словаре - чтоб не проверять на все другие 300+ ненужных вариантов. И с select case чуть меньше букв будет.
Да, что-то я там с сплитом зря связался, сразу делать array лучше. Только первый массив делать из чисел текстом, второй из чисел, т.к. ключ нужен текстом, а номер столбца числом - тогда отпадают лишние преобразования в дальнейшем. И проверки на t = "5" и t ="25" целесообразно поместить внутрь проверки на наличие в словаре - чтоб не проверять на все другие 300+ ненужных вариантов. И с select case чуть меньше букв будет.Hugo
Hugo, проверку на t = "5" и t ="25" поместил вот так [vba]
Код
If .exists(t) Then If t = "5" Or t = "25" Then Cells(ind, --.Item(t)) = CDate(Right(Split(b(ii), "=")(1), 2) & "." & Mid(Split(b(ii), "=")(1), 5, 2) & "." & Left(Split(b(ii), "=")(1), 4)) Else Cells(ind, --.Item(t)) = Split(b(ii), "=")(1) End If End If
[/vba]
Hugo, проверку на t = "5" и t ="25" поместил вот так [vba]
Код
If .exists(t) Then If t = "5" Or t = "25" Then Cells(ind, --.Item(t)) = CDate(Right(Split(b(ii), "=")(1), 2) & "." & Mid(Split(b(ii), "=")(1), 5, 2) & "." & Left(Split(b(ii), "=")(1), 4)) Else Cells(ind, --.Item(t)) = Split(b(ii), "=")(1) End If End If
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
Ведь не сделано "набор обрабатываемых полей определю сам." 
