[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 как в "проводнике"