Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Свод данных из нескольких файлов в 1 по условию
 
#1
02.04.2012 20:45:07
Добрый вечер!  
Есть 6 файлов эксель, очень больших. в каждом из них ФИО и значения всякие, соответствующие этому фио (БД с кучей строк). задача в следующем, сразу на примере: все записи с фио Иванов скопировать в отдельный файл, где на 1-ой вкладке - данные первого файла по фио иванов, на 2-ой вкладке - данные второго файла... и т.д.  
Пример во вложении. Для упрощения сделал только 2 файла. Суть не меняется. В исходных файлах может содержатся куча фио, мне же нужно выбрать только определенные (необходимые), и создать для каждого фио отдельный файл...
 
 
 
#2
03.04.2012 14:25:30
Задача упрощается (наверное). Надеюсь, кто-нибудь поможет...  
Есть файл, в нем куча строк - фио разные и значения, им соответствующие (во вложении это, к примеру, файл 1). В другом файле у меня есть ячейка с раскрывающимся списком определенных ФИО (их меньше, чем в исходном файле с данными). Я из списка выбираю нужное фио, запускаю макрос, и у меня создается файл с именем "Файл 1_Иванов.xlsx", содержащий записи только по выбранному ФИО.  
 
Надеюсь на отклики, и на то, что данная задача не слишком трудна.  
Спасибо.
 
 
 
#3
03.04.2012 14:41:25
Задача не сложная.  
И макрос уже есть, как раз сегодня на другом форуме чуть подправлял (написал его ядро раньше):  
 
Sub Perenos()  
 
   Dim WBk As Workbook  
   Dim ПутьКПапке As String  
   Dim WSheet As Worksheet  
   Dim ПутьКФайлу As String  
 
   Set WBk = ThisWorkbook  
   Set WSheet = WBk.Worksheets("ОПС-2")  
   Dim x As Range, rr As Range: Application.ScreenUpdating = False  
   Set x = [E:E].Find(102, , , xlWhole)
   If Not x Is Nothing Then  
       [E:E].ColumnDifferences(x).EntireRow.Hidden = True
       Set rr = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).EntireRow  
       Rows.Hidden = False  
 
       Dim sh As Worksheet  
       Set sh = Workbooks.Add.Sheets(1)  
       sh.[a1] = "Сотрудник"
       sh.[b1] = "Год начисления"
       sh.[c1] = "Месяц регистрации"
       sh.[d1] = "Месяц действия"
       sh.[e1] = "Вид расчёта"
       sh.[f1] = "Сумма"
 
       rr.Copy sh.[a2]
 
       rr.Delete  
   End If  
 
 
   ПутьКПапке = WBk.Path & "\DBF1\"  
   On Error Resume Next: MkDir ПутьКПапке  
   ПутьКФайлу = ПутьКПапке & "Сдельная" & WSheet.Range("J1") & WSheet.Range("K1") & ".xls"  
 
   sh.Parent.SaveAs FileName:=ПутьКФайлу, FileFormat:=xlNormal, CreateBackup:=False  
 
   sh.Parent.Close 0  
 
End Sub  
 
 
 
Здесь отбор по 102 - замените на свою фамилию.  
Ну и заголовки нужны/ненужны, пути свои задайте. Сохранение подпраьвте.  
Поиск тоже может быть не нужен, если фамилия гарантированно в списке есть.
 
 
 
#4
03.04.2012 14:46:48
Хотя поиск или его аналог нужен - нужно ведь как-то указать на любую ячейку с этим критерием.
 
 
 
#5
03.04.2012 21:01:07
Если я правильно понял, то данный макрос должен располагаться в файле с исходными данными. Мне же нужно, чтобы макрос был в другой книге, а обрабатывать макрос будет исходник, который будет лежать где-то в папке и открываться не будет во время этого процесса...  
Если я не так понял, исправьте, и простите...) С vba я на пока на Вы...
 
 
 
#6
03.04.2012 21:14:51
Ну как макрос напишешь - так он и будет работать.  
Этот работает с ThisWorkbook, а можно работать с ActiveWorkbook, или например  
 
Dim wb As Workbook: Set wb = Workbooks.Open(ИмяФайла, , True) ' открываем файл  
wb.Worksheets(1).Range("a2:h8").Copy sh.Range("a1") ' копируем a2:h8 из открытой книги в текущую  
wb.Close False ' закрываем открытую книгу  
 
Можно прописать адрес нужной книги явно, можно поискать в каталоге и выбрать нужную кодом (например по текущей дате), можно это дать на откуп пользователю...  
 
"открываться не будет" - будет. Ну разве что если формулами тянуть - но это не тот случай.  
Или если использовать запрос SQL к файлу - так он вроде как и не будет открываться.  
Поищите темы или подождите спецов по SQL - я лучше помолчу... :)
 
 
 
#7
03.04.2012 21:15:26
Если есть возможность - адаптируйте, плиз, макрос, воткнув его в пример во вложении.    
Суть задачи: в книге1 список ФИО. Нужно создать в соответствии со списком файлы с данными по каждому из фио отдельно (данные находятся в файле 1).  
Т.е. результатом будут 2 файла, Иванов.xlsx и Петров.xlsx.
 
 
 
#8
03.04.2012 21:19:40
Хотя вот для начала нашёл цитату:  
 
============================================================­==  
EugeneS    
Форумчанин  
   
могу Вам предложить такой вариант с иcпользованием SQL:  
 
Предварительнно необходимо подключить библиотеку: Alt+F11 - Tools - References - Microsoft ActiveX Data Object 2.0 (или выше)  
Будучи на Листе1, запустите макрос "Отбор"  
 
Код:  
 
Sub Отбор()  
Dim cn As New ADODB.Connection, rs As New ADODB.Recordset: Application.ScreenUpdating = False  
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ";Extended Properties=""Excel 8.0;HDR=No;"";"  
rs.Open "SELECT T2.F1,(SELECT T1.F2 FROM [Лист1$A2:B65536] T1 WHERE T1.F1=T2.F1) FROM [Лист2$A2:A65536] T2", cn, adOpenStatic, adLockReadOnly
With Sheets(3): .Activate: [b:b].Clear: [a2].CopyFromRecordset rs: Set rs = Nothing: Set cn = Nothing: End With: End Sub
   
============================================================­==  
Можно текст запроса подсмотреть в Access или MSQuery взять мастером.  
Но я не особо разбираюсь...
 
 
 
#9
03.04.2012 21:47:14
Адаптировал.  
Путь к обоим файлам:  
c:\Temp\ferzios\  
Туда же положите c:\Temp\ferzios\Файл 1.xlsx  
Результаты будут тут же.  
 
 
Код чуть укоротил - повыкидывал лишнее:  
 
 
Option Explicit  
 
Sub Perenos()  
 
   Dim wb As Workbook  
   Dim Sh As Worksheet  
   Dim nSh As Worksheet  
   Dim cc As Range  
 
   Application.ScreenUpdating = False  
 
   Set wb = Workbooks.Open("c:\Temp\ferzios\Файл 1.xlsx", , True)  
   Set Sh = wb.Sheets("Данные 1")  
 
   For Each cc In ThisWorkbook.Worksheets("Молодчики").Range("A1").CurrentRegion.Cells  
 
       With Sh  
           Dim x As Range, rr As Range: Application.ScreenUpdating = False  
           Set x = .[A:A].Find(cc.Value, , , xlWhole)
           If Not x Is Nothing Then  
               .[A:A].ColumnDifferences(x).EntireRow.Hidden = True
               Set rr = .UsedRange.SpecialCells(xlCellTypeVisible).EntireRow  
               .Rows.Hidden = False  
 
               Set nSh = Workbooks.Add(1).Sheets(1)  
 
               nSh.[a1] = "ФИО"
               nSh.[b1] = "Данные1"
               nSh.[c1] = "Данные2"
               nSh.[d1] = "Цифра1"
               nSh.[e1] = "Цифра2"
 
               rr.Copy nSh.[a2]
 
           End If  
       End With  
 
       nSh.Parent.SaveAs Filename:=ThisWorkbook.Path & "\" & cc.Value & ".xlsx"  
       nSh.Parent.Close 0  
 
   Next  
   wb.Close 0  
   Application.ScreenUpdating = True  
End Sub
 
 
 
#10
03.04.2012 21:53:07
Чуть ошибся - пару строк внутрь цикла нужно передвинуть (замените код на этот, в той версии может быть ошибка например на Козлове :( ):  
 
 
Option Explicit  
 
Sub Perenos()  
 
   Dim wb As Workbook  
   Dim Sh As Worksheet  
   Dim nSh As Worksheet  
   Dim cc As Range  
 
   Application.ScreenUpdating = False  
 
   Set wb = Workbooks.Open("c:\Temp\ferzios\Файл 1.xlsx", , True)  
   Set Sh = wb.Sheets("Данные 1")  
 
   For Each cc In ThisWorkbook.Worksheets("Молодчики").Range("A1").CurrentRegion.Cells  
 
       With Sh  
           Dim x As Range, rr As Range  
           Set x = .[A:A].Find(cc.Value, , , xlWhole)
           If Not x Is Nothing Then  
               .[A:A].ColumnDifferences(x).EntireRow.Hidden = True
               Set rr = .UsedRange.SpecialCells(xlCellTypeVisible).EntireRow  
               .Rows.Hidden = False  
 
               Set nSh = Workbooks.Add(1).Sheets(1)  
 
               nSh.[a1] = "ФИО"
               nSh.[b1] = "Данные1"
               nSh.[c1] = "Данные2"
               nSh.[d1] = "Цифра1"
               nSh.[e1] = "Цифра2"
 
               rr.Copy nSh.[a2]
 
               nSh.Parent.SaveAs Filename:=ThisWorkbook.Path & "\" & cc.Value & ".xlsx"  
               nSh.Parent.Close 0  
 
           End If  
       End With  
 
   Next  
   wb.Close 0  
   Application.ScreenUpdating = True  
End Sub
 
 
 
#11
04.04.2012 16:25:28
Вопроса два:  
1) Возможно ли не задавать в коде значения шапки, а копировать их из исходника?  
2) Как добавить еще одно условие: Значения столбца В равны "Москва", например. Т.е. Иванов и Москва (Москва является постоянным фильтром).
 
 
 
#12
04.04.2012 16:51:47
Можно и так сделать.  
Можно шапку копировать (одна строка: .[A1:E1].Copy nSh.[A1]), но если делать п.2, то шапка скопируется автоматически вместе с отфильтрованными данными (т.к. механизм чуть другой):
 
Option Explicit  
 
Sub Perenos()  
 
   Dim wb As Workbook  
   Dim Sh As Worksheet  
   Dim nSh As Worksheet  
   Dim cc As Range  
 
   Application.ScreenUpdating = False  
 
   Set wb = Workbooks.Open("c:\Temp\ferzios\Файл 1.xlsx", , True)  
   Set Sh = wb.Sheets("Данные 1")  
 
   For Each cc In ThisWorkbook.Worksheets("Молодчики").Range("A1").CurrentRegion.Cells  
 
       With Sh  
           Dim x As Range, rr As Range  
           Set x = .[A:A].Find(cc.Value, , , xlWhole)
           If Not x Is Nothing Then  
 
               .AutoFilterMode = 0  
               With .[a1].CurrentRegion
                   .AutoFilter 1, cc.Value, 1: .AutoFilter 2, "Москва", 1  
                   Set rr = .SpecialCells(12)  
               End With  
               .AutoFilterMode = 0  
 
               Set nSh = Workbooks.Add(1).Sheets(1)  
               rr.Copy nSh.[a1]
 
               nSh.Parent.SaveAs Filename:=ThisWorkbook.Path & "\" & cc.Value & ".xlsx"  
               nSh.Parent.Close 0  
 
           End If  
       End With  
 
   Next  
   wb.Close 0  
   Application.ScreenUpdating = True  
End Sub  
 
 
Кстати, слово "Москва" тоже можно менять, например брать его из ячейки с того же листа, где "молодчики", или спрашивать у пользователя в диалоге.
 
 
 
#13
04.04.2012 17:06:55
А где задается столбец, в котором ищем Москву?
 
 
 
#14
04.04.2012 17:20:12
Вообщем, в идеале нужно так: столбец В используется в качестве фильтра по регионам. Т.е. столбец А - фильтр по ФИО (это уже работает отлично), столбец В - фильтрует таким же образом по столбцу 3 исходного файла.  
И все это загнать в цикл где будут меняться файлы, т.е.  
Set wb = Workbooks.Open("c:\Temp\ferzios\Файл 1.xlsx", , True)  
Файл 1, Файл 2,... Файл 6 - прогоняем 6 файлов.  
Соответственно, результатом по Иванову получаем:    
Иванов_Файл 1.xlsx  
Иванов_Файл_2.xlsx  
...  
Иванов_Файл_6.xlsx
 
 
 
#15
04.04.2012 17:35:40
1. В строке  
.AutoFilter 1, cc.Value, 1: .AutoFilter 2, "Москва", 1  
AutoFilter номер_столбца  
 
2. Вариант с циклом по файлам.  
Но нет обработки ошибки, если файл не найден.  
 
 
Option Explicit  
 
Sub Perenos()  
 
   Dim wb As Workbook  
   Dim Sh As Worksheet  
   Dim nSh As Worksheet  
   Dim cc As Range  
   Dim nrf As Byte  
 
   Application.ScreenUpdating = False  
 
   For nrf = 1 To 6  
 
       Set wb = Workbooks.Open("c:\Temp\ferzios\Файл " & nrf & ".xlsx", , True)  
       Set Sh = wb.Sheets("Данные 1")  
 
       For Each cc In ThisWorkbook.Worksheets("Молодчики").Range("A1").CurrentRegion.Cells  
 
           With Sh  
               Dim x As Range, rr As Range  
               Set x = .[A:A].Find(cc.Value, , , xlWhole)
               If Not x Is Nothing Then  
 
                   .AutoFilterMode = 0  
                   With .[a1].CurrentRegion
                       .AutoFilter 1, cc.Value, 1: .AutoFilter 2, "Москва", 1  
                       Set rr = .SpecialCells(12)  
                   End With  
                   .AutoFilterMode = 0  
 
                   Set nSh = Workbooks.Add(1).Sheets(1)  
                   rr.Copy nSh.[a1]
 
                   nSh.Parent.SaveAs Filename:=ThisWorkbook.Path & "\" & cc.Value & "_Файл_" & nrf & ".xlsx"  
                   nSh.Parent.Close 0  
 
               End If  
           End With  
 
       Next  
       wb.Close 0  
   Next  
   Application.ScreenUpdating = True  
End Sub  
 
 
 
Вместо "Москва" Вам вероятно нужно написать cc.offset(,1).Value - это будет значение правее фамилии на одну ячейку, т.е. столбец B.
 
 
 
Страницы: 1
Читают тему
Наверх