[решено] Excel 2010 фильтр 1 и 2 листа скопировать на новый лист

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)

- - [решено] Excel 2010 фильтр 1 и 2 листа скопировать на новый лист (http://forum.oszone.net/showthread.php?t=246033)

The Off

02-11-2012 13:55 2017258

Excel 2010 фильтр 1 и 2 листа скопировать на новый лист

Всем привет! Не знаю как решить во такую задачку - на 1 и на 2 листе Информация из трех столбцов:
в первом она повторяется числовая в принципе с ней ничего не нужно делать только выносить на новую страницу со всей строкой
во втором уникальна числовая (но может совпадать в листе1 с лист2) можно считать что это ID
в третьем ФИО
Нужно отфильтровать и вывести ТОЛЬКО УНИКАЛЬНЫЕ значения только со второго листа, уникальные значения первого листа не нужны, на новую страницу фильтр нужно вести по двум параметрам ФИО и ID

Как это вообще можно сделать - я знаю но способ очень кривой, занимает много времени и повторять его нужно для 23 файлов - не хочется) в каждом от 2 тыс. записей
Подскажите как можно это реализовать ?
Заранее благодарен.

Таблица выглядит примерно так - состоит из 2-8 тысяч записей, нужно вынести "появившиеся" во втором листе записи, которых НЕТ в листе 1

okshef

02-11-2012 14:14 2017276

Данные - Удалить дубликаты

The Off

02-11-2012 14:18 2017284

Цитата:

Цитата okshef

Данные - Удалить дубликаты »

Так ведь это удаляет дубликаты только на текущем листе

okshef

04-11-2012 13:34 2018439

The Off, заполните верхнюю строчку на листе 3 (например, "Номер", "ID", "ФИО") - обязательно. Добавьте модуль, вставьте в него текст

Код:

Sub findnew()

    For Each c In Worksheets(2).Columns(2).Cells

        If Worksheets(1).[b:b].Find(c.Value) Is Nothing Then

             Worksheets(2).Range("a" & c.Row & ":c" & c.Row).Copy Worksheets(3).Range("a" & Worksheets(3).Cells.Rows.Count).End(xlUp)(2)

        End If

     If IsEmpty(c) Then Exit For

     Next

 End Sub

и запустите

Формулами решение, наверное, есть, но честно, лень искать.

Предполагалось, что ID и ФИО все-таки соответствуют друг другу.

The Off

06-11-2012 14:52 2020065

okshef, Огромное Вам спасибо !!! Я поначалу даже и не думал о модулях !!! Теперь не придется тратить каждый месяц на это целую кучу рабочего времени

okshef

06-11-2012 15:31 2020107

The Off, спасибо за отзыв, рад, что смог помочь, хотя не считаю себя большим спецом в Excel. Код немного поправил - удалил ненужную строчку. Функциональность не меняется, но чуть-чуть ускоряется.

The Off

06-11-2012 15:38 2020120

okshef, ну ты быстро сообразил, как это можно реализовать, я бы только завтра догадался, что можно это с помощью модуля сделать, у меня будет еще 1 вопрос, но по access, изложу немного позже в новой теме, когда появится время

okshef, подскажи пожалуйста как добавить еще один столбец в выборку ? я просто в программировании вообще не силен...

okshef

08-11-2012 12:11 2021429

Поточнее можно?

The Off

08-11-2012 12:13 2021432

okshef, ну появилась необходимость делать выборку еще по одному критерию получается таблица будет состоять уже из 4 столбцов вот нужно новый четвертый добавить это можно сказать "второй ID"

okshef

08-11-2012 12:23 2021439

Сделайте примерный файл из 10 строчек с желаемым результатом (кнопка "Прикрепить файл" справа от окна ввода сообщения).

The Off

08-11-2012 12:41 2021456

Вложений: 1

Пример 10 строк с желаемым результатом

okshef

08-11-2012 12:51 2021461

То есть критерий отбора останется тот же, но в результаты нужно добавить 4-й столбец? Или все-таки 4-й столбец является критерием отбора?

The Off

08-11-2012 13:03 2021467

4-й столбец так же является критерием поиска

okshef

08-11-2012 13:14 2021474

Простите за массу уточняющих вопросов, но наличие 2-го критерия значительно усложняет задачу.
То есть алгоритм поиска выглядит так:
1) сравнить листы по второму столбцу
2) в случае отсутствия данных перейти к четвертому столбцу
3) если данные не совпадают - перенести на лист 3
4) если данные в 4-м столбце совпадают - продолжить поиск
Так?

The Off

08-11-2012 13:28 2021488

1) сравнить листы по второму столбцу
2) если данные не совпадают - перенести на лист 3
3) если данные в 4-м столбце совпадают - продолжить поиск

то есть 4 столбец мы смотри уже среди найденных в 1 пункте

okshef

08-11-2012 13:58 2021507

Опять неясность: то есть перенос в любом случае осуществляется при отсутствии в списке на листе 1 только по критерию 2.

Цитата:

Цитата The Off

если данные в 4-м столбце совпадают - продолжить поиск »

он и так продолжится... Какую роль играет критерий 4?

The Off

08-11-2012 14:19 2021521

Вложений: 1

Прошу прощения, задавал очень глупые вопросы, уже придумал решение, но теперь нужно оставить выборку как и была и на третий лист копировать только первый и третий столбцы. То есть без столбца, по которому выполнялась выборка.

okshef

08-11-2012 14:47 2021534

Код:

Sub findnew()

    For Each c In Worksheets(2).Columns(3).Cells

        If Worksheets(1).[c:c].Find(c.Value) Is Nothing Then

             Worksheets(2).Range("a" & c.Row).Copy Worksheets(3).Range("a" & Worksheets(3).Cells.Rows.Count).End(xlUp)(2)

             Worksheets(2).Range("c" & c.Row).Copy Worksheets(3).Range("b" & Worksheets(3).Cells.Rows.Count).End(xlUp)(2)

        End If

     If IsEmpty(c) Then Exit For

     Next

End Sub

Код поправил.

The Off

08-11-2012 15:06 2021546

okshef, Все работает как нужно !!! СПАСИБО ОГРОМНОЕ !!!

Еще одно - нужно удалить дубликаты на получившемся списке (некоторые записи повторяются дважды во втором листе только обнаружил) как это добавить в модуль?

okshef

08-11-2012 21:11 2021801

Добавьте после Next

Код:

Worksheets(3).UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

The Off

09-11-2012 14:09 2022259

Вложений: 1

okshef, он выдает ошибку

okshef

09-11-2012 16:13 2022379

The Off, поправил код. Точно, у вас же 2 столбца.

The Off

15-11-2012 11:59 2025959

okshef, все равно ругается (

okshef

15-11-2012 16:42 2026178

Вставьте модуль с таким кодом:

Код:

Sub findnew()

10        On Error GoTo LogError

20            For Each c In Worksheets(2).Columns(2).Cells

30                If Worksheets(1).[b:b].Find(c.Value) Is Nothing Then

40                    Worksheets(2).Range("a" & c.Row).Copy Worksheets(3).Range("a" & Worksheets(3).Cells.Rows.Count).End(xlUp)(2)

50                    Worksheets(2).Range("c" & c.Row).Copy Worksheets(3).Range("b" & Worksheets(3).Cells.Rows.Count).End(xlUp)(2)

60                End If

70                If IsEmpty(c) Then Exit For

80            Next

90        Worksheets(3).UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

100   Exit Sub

LogError:

110       ErrorMsg = Now & " " & _

          "Error " & Err.Number & " (" & Err.Description & _

          ") in procedure findnew строка " & Erl

120       MsgBox ErrorMsg

130       With ThisWorkbook

140           Shell "cmd /c echo " & ErrorMsg & ">>""" & .Path & "\" & .Name & ".log"""

150       End With

160       Resume Next

End Sub

В папке с файлом образуется лог работы - приложите его к сообщению

The Off

16-11-2012 12:19 2026723

Вложений: 1

код чуть переделал (появилась необходимость добавить еще 1 столбец)

Код:

Sub findnew()

      On Error GoTo LogError

          For Each c In Worksheets(2).Columns(2).Cells

                If Worksheets(1).[b:b].Find(c.Value) Is Nothing Then

                    Worksheets(2).Range("a" & c.Row).Copy Worksheets(3).Range("a" & Worksheets(3).Cells.Rows.Count).End(xlUp)(2)

                    Worksheets(2).Range("c" & c.Row).Copy Worksheets(3).Range("b" & Worksheets(3).Cells.Rows.Count).End(xlUp)(2)

                    Worksheets(2).Range("d" & c.Row).Copy Worksheets(3).Range("c" & Worksheets(3).Cells.Rows.Count).End(xlUp)(2)

              End If

                If IsEmpty(c) Then Exit For

            Next

        Worksheets(3).UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes

   Exit Sub

LogError:

      ErrorMsg = Now & " " & _

          "Error " & Err.Number & " (" & Err.Description & _

          ") in procedure findnew строка " & Erl

      MsgBox ErrorMsg

       With ThisWorkbook

           Shell "cmd /c echo " & ErrorMsg & ">>""" & .Path & "\" & .Name & ".log"""

       End With

       Resume Next

выдает вот такую ошибку

файл с логом - пустой

okshef

16-11-2012 14:58 2026805

Вложений: 1

У меня все выполняется без ошибок

Другие файлы не открыты? Excel точно 2010?

The Off

01-08-2013 16:41 2194594

okshef, а возможно ли подтягивать точно так же данные из разных файлов? например не из лист1-лист2 а из файлов filename1 и filename2

okshef

02-08-2013 02:07 2194925

The Off, я сам не делал, попробуйте. Введите переменные, как вы их назвали

Цитата:

Цитата The Off

filename1 и filename2 »

и пропишите полный путь к файлу

Код:

Set filename1=x:\dir1\dir2\dir3\file1.xls

Set filename2=x:\dir4\dir5\dir6\file2.xls

А дальше "привяжите" к этому файлу рабочий лист, например, строчку

Код:

Worksheets(2).Range("a" & c.Row).Copy Worksheets(3).Range("a" & Worksheets(3).Cells.Rows.Count).End(xlUp)(2)

измените

Код:

filename1.Worksheets(2).Range("a" & c.Row).Copy filename2.Worksheets(3).Range("a" & filename2.Worksheets(3).Cells.Rows.Count).End(xlUp)(2)

Думаю, должно получиться. Только не могу точно сказать, должны ли быть файлы открыты.

Ох и тяжко вспоминать задачки почти годовалой давности :)

The Off

02-08-2013 09:58 2195023

Сделал вот так, он мне скопировал все как нужно, во время "написания" заметил фишку в том, что в одних excel таблицах столбцы обозначаются как 123456 а в других abcdef - это слияет на код ? например If filename1.Worksheets(1).[c:c].Find(c.Value) Is Nothing Then или же If filename1.Worksheets(1).[3:3].Find(c.Value) Is Nothing Then

Код:





Sub findnew()







     Set filename1 = GetObject("D:\newpens\at06.xls ")



     Set filename2 = GetObject("D:\newpens\at07.xls")

   

            

            For Each c In filename2.Worksheets(1).Columns(3).Cells

                If filename1.Worksheets(1).[c:c].Find(c.Value) Is Nothing Then

                

          filename2.Worksheets(1).Range("a" & c.Row).Copy Worksheets(1).Range("a" & Worksheets(1).Cells.Rows.Count).End(xlUp)(2)

          filename2.Worksheets(1).Range("b" & c.Row).Copy Worksheets(1).Range("b" & Worksheets(1).Cells.Rows.Count).End(xlUp)(2)

          filename2.Worksheets(1).Range("d" & c.Row).Copy Worksheets(1).Range("c" & Worksheets(1).Cells.Rows.Count).End(xlUp)(2)

          

             

                End If

                If IsEmpty(3) Then Exit For

            Next

    '    Worksheets(1).UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes

   Exit Sub



       Resume Next

End Sub

The Off

02-08-2013 13:39 2195172

Еще вопрос по инету шарю - пока найти не могу, как сделать так, что бы нужно было "указывать" файл 1 и файл 2 как в "проводнике"

okshef

03-08-2013 09:18 2195546

Нашел вот такой код (http://www.excelworld.ru/forum/2-2898-1). Нужно только "допилить под себя"

Код:

Sub Импорт()

     Dim BazaWb As Workbook    'файл для сбора данных

     Dim SelectedItem As String    'имя файла выбранного в диалоге



     MsgBox "Внимание!!!Необходимо выбрать уже заполненный файл.  следуйте инструкции!"



     'вызываем диалог выбора папки с файлами отчёта

     With Application.FileDialog(msoFileDialogFilePicker)

         .Title = "Выберите файл для отчета"    'надпись в окне диалога

         'путь по умолчанию к папке /где расположен исходный файл

         .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "*.xlsx*"

         .AllowMultiSelect = False    'запрет выбора нескольких файлов

         If .Show = False Then GoTo ErrShow:

         SelectedItem = .SelectedItems(1)    'при обработке нескольких - удалить

     End With

     With Application

         'отлючаем системные сообщения

         .DisplayAlerts = False

         'отлючаем обновление экрана - это убыстрит работу макроса

         .ScreenUpdating = False

         'включаем ручной пересчёт формул - это убыстрит работу макроса

         .Calculation = xlManual

         'отключаем отображения окон на панели задач на время выполнения макроса

         .ShowWindowsInTaskbar = False

     End With

     'присваиваем переменной BazaWb ссылку на общий файл

     Set BazaWb = ThisWorkbook

     With Workbooks.Open(SelectedItem)

         On Error Resume Next

         'операции с открытой книгой

        .....

       'здесь ваш код

        .....

         .Close False    'закрываем книгу

     End With

        .....

       'здесь ваш код

        .....

     On Error GoTo 0

 ErrShow:

     With Application

         'включаем автоматический пересчёт формул, который отключили в начале макроса

         .Calculation = xlAutomatic

         'включаем отображения окон на панели задач, которое отключали в начали макроса

         .ShowWindowsInTaskbar = True

         'включаем обновление экрана, который отключили в начале макроса

         .ScreenUpdating = True

         .DisplayAlerts = False

     End With

End Sub

Время: 09:56.