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

[The Off]

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

[okshef]

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

[The Off]

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

[okshef]

Вставьте модуль с таким кодом:
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]

код чуть переделал (появилась необходимость добавить еще 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]

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

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

[The Off]

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

[okshef]

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]

Сделал вот так, он мне скопировал все как нужно, во время "написания" заметил фишку в том, что в одних 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]

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

[okshef]

Нашел вот такой код (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