"Прикрутить" столбец из другого файла с условием

[blackeangel]

Всем привет. Есть задачка:
имеется 2 файла:
в 1м файле перечень
во 2м файле перечень и еще один столбец.
Необходимо к перечню 1го файла прикрутить тот столбец что во втором файле, учитывая что перечни не полностью совпадают и расположение совпадающих различно.
Пример прилагаетсяв трех файлах:1й файл,2й файл и результирующий.

Ошибочный итоговый файл был
Вот верный. Реализовать надо в макросе..

В общем все сводится к тому что: есть список(файл1) и есть база (файл2).Из базы в список копируются необходимые данные, если не совпали,то пропускается(остаётся пустая ячейка)

[blackeangel]

Вот кривой, помогите поправить и доделать с переносом на новый лист по причине того что встречается несколько раз одно обозначение с разными данными

Sub osnastka()
Application.ScreenUpdating = False
i = 2
' работаем с активной книгой
sWhatFind2 = "Обозначение"
Cells.Find(What:=sWhatFind2, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn2 = ActiveCell.Column ' нашли столбец с обозначением
Columns(ncolumn2 + 1).Insert 'вставляем столбец справа
Cells(1, ncolumn2 + 1).Value = "Инструм." 'вставляем заголовок столбца
' работаем с "базой"
sWhatFind = "№ детали"
sWhatFind3 = "Инструм."
n = ThisWorkbook.Path & "" & "Оснастка.xlsx"
Set s = GetObject(n)
Set ndetali = s.Worksheets(1).Cells.Find(What:=sWhatFind, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
k = ndetali.Column
Set ninstrum = s.Worksheets(1).Cells.Find(What:=sWhatFind3, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
l = ninstrum.Column
MsgBox "cell= " & Cells(i, k).Value
'цикл
Do While Cells(i, ncolumn2).Value <> Empty 'поставил на "Обозначение" т.к. обрывался на пустой ячейке
If Cells(i, k).Value Like Cells(i, ncolumn2).Value Then
Cells(i, ncolumn2 + 1).Value = s.Worksheets(1).Cells(i.Row, l)
End If
i = i + 1
Loop
s.Close SaveChanges:=False 'закрываем файл без сохранения
End Sub

Если есть вариант через массивы сделать то буду рад

[blackeangel]

Вот для большей ясности

[a_axe]

Реализовать надо в макросе.. »
blackeangel, макрос - это обязательное требование? Почему нельзя сделать это стандартными средствами Excel?
Updated:
Один из способов реализовать стандартными способами:
в файле 1файл выберите: вкладка "Данные", группа "Получение внешних данных", кнопка "Существующие подключения". В диалоге нажмите кнопку "Найти другие...", в следующем диалоге выберите файл 2файл, лист 1.

Способ вставки - таблица, место вставки - новый лист, в свойствах нужно выставить частоту обновлений (только при открытии, каждые 10 минут и т.п.). Данные второго свяжутся с файлом 1 и автоматически будут обновляться , даже если второй файл закрыт.

Соответственно в столбец "Закуска" файла 1файл нужно вбить формулу "=ЕСЛИОШИБКА(ВПР(A7;Таблица__2файл;4;ЛОЖЬ);"")"

При изменении данный в вашем втором файле соответственно изменится заполнение в фале №1.
Для файла "оснастка.xlsx" можно сделать по аналогии.

[blackeangel]

Реализовать надо в макросе.. »
blackeangel, макрос - это обязательное требование? Почему нельзя сделать это стандартными средствами Excel?
Updated:
Один из способов реализовать стандартными способами:
в файле 1файл выберите: вкладка "Данные", группа "Получение внешних данных", кнопка "Существующие подключения". В диалоге нажмите кнопку "Найти другие...", в следующем диалоге выберите файл 2файл, лист 1.

Способ вставки - таблица, место вставки - новый лист, в свойствах нужно выставить частоту обновлений (только при открытии, каждые 10 минут и т.п.). Данные второго свяжутся с файлом 1 и автоматически будут обновляться , даже если второй файл закрыт.

Соответственно в столбец "Закуска" файла 1файл нужно вбить формулу "=ЕСЛИОШИБКА(ВПР(A7;Таблица__2файл;4;ЛОЖЬ);"")"

При изменении данный в вашем втором файле соответственно изменится заполнение в фале №1.
Для файла "оснастка.xlsx" можно сделать по аналогии.
Увы, нужен именно макрос

[a_axe]

нужен именно макрос »
blackeangel, могу предложить следующий код с оговорками:
Код должен храниться в рабочей книге, куда вы хотите скопировать данные. Оба файла должны быть открыты, кроме них рабочих книг открывать нельзя. Логика следующая - код будет копировать данные в ту книгу, где хранится он сам, источником он считает вторую открытую книгу.
Заголовки хранятся в строке №1 каждого файла. Столбец с данными для копирования должен иметь номер на единицу больше, чем столбец "№ детали" в файле источнике.

Public Sub osn()
Dim dataBook As Workbook
Dim dataSheet As Worksheet
Dim myCell As Range
Dim i As Integer, j As Integer
If Application.Workbooks.Count = 2 Then
For Each dataBook In Application.Workbooks
If dataBook.Name <> ThisWorkbook.Name Then Set dataSheet = dataBook.ActiveSheet

Next
i = dataSheet.Rows(1).Find(What:="№ детали", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
j = ThisWorkbook.ActiveSheet.Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column + 1
Debug.Print dataSheet.Name
Debug.Print i & " " & j
For Each myCell In Intersect(ThisWorkbook.ActiveSheet.UsedRange, ThisWorkbook.ActiveSheet.Columns(j))
On Error Resume Next
Err.Clear
myCell.Value = Application.WorksheetFunction.VLookup(myCell.Offset(0, -1).Value, _
Range(dataSheet.Cells(1, i), dataSheet.Cells(dataSheet.UsedRange.Count, i + 1)), 2, False)
If Err.Number <> 0 Then myCell.Value = ""

Next
ThisWorkbook.ActiveSheet.Cells(1, j).Value = "Инструм."
Else
MsgBox "Должно быть открыто 2 файла."
End If
Set dataSheet = Nothing
End Sub

[blackeangel]

Я сделал вот так

Sub osnastka()
Application.ScreenUpdating = False
i = 2
' работаем с активной книгой
sWhatFind2 = "Обозначение"
Cells.Find(What:=sWhatFind2, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn2 = ActiveCell.Column ' нашли столбец с обозначением
Columns(ncolumn2 + 1).Insert 'вставляем столбец справа
Cells(1, ncolumn2 + 1).Value = "Инструм." 'вставляем заголовок столбца
' работаем с "базой"
sWhatFind = "№ детали"
sWhatFind3 = "Инструм."
n = ThisWorkbook.Path & "" & "оснастка.xlsx"
Set s = GetObject(n)
Set ndetali = s.Worksheets(1).Cells.Find(What:=sWhatFind, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
k = ndetali.Column
Set ninstrum = s.Worksheets(1).Cells.Find(What:=sWhatFind3, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
l = ninstrum.Column
'MsgBox "cell= " & Cells(i, k).Value
'цикл
lLR = s.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Do While ActiveSheet.Cells(i, ncolumn2).Value <> Empty 'поставил на "Обозначение" т.к. обрывался на пустой ячейке
For j = 2 To lLR
If Cells(i, ncolumn2).Value Like s.Worksheets(1).Cells(j, k).Value Then
Cells(i, ncolumn2 + 1).Value = s.Worksheets(1).Cells(j, l).Value
End If
Next j
i = i + 1
Loop
s.Close SaveChanges:=False 'закрываем файл без сохранения
Application.ScreenUpdating = True
End Sub

Но есть огромный недостаток-учитывает только первую входимость, а надо все...
Для перебора 30к позиций хватает...больше уже вешается...
Здесь надо через массивы... Но как хз,я в них ни але
Если что - код, в любом случае, будет в надстройке....
Ах да, и как оказалось, столбцов из базы(2 файл) надо брать 3... И располагаются они хаотично..

[a_axe]

учитывает только первую входимость, а надо все...
Если что - код, в любом случае, будет в надстройке....
Ах да, и как оказалось, столбцов из базы(2 файл) надо брать 3... И располагаются они хаотично.. »
Постоянно меняющиеся исходные данные затрудняют поиск решения вашей проблемы.

Здесь надо через массивы... Но как хз,я в них ни але »
Из конструктивных предложений - освойте массивы (http://perfect-excel.ru/publ/excel/makrosy_i_programmy_vba/massivy_v_vba/7-1-0-74), чтобы ваша уверенность в необходимости их использования имела под собой хоть какие-то вразумительные аргументы.
Кроме того, тематических ресурсов по VBA великое множество, помнится у одного из участников подобного форума была очень подходящая к случаю подпись к сообщениям: Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы... . Набейте в любом поисковике VBA и после этого слова подпись - и обязательно найдете этот ресурс с большим количеством материала для вашего самообразования. Лично я бы уделил больше времени самой подписи в силу ее универсальности.

[blackeangel]

учитывает только первую входимость, а надо все...
Если что - код, в любом случае, будет в надстройке....
Ах да, и как оказалось, столбцов из базы(2 файл) надо брать 3... И располагаются они хаотично.. »
Постоянно меняющиеся исходные данные затрудняют поиск решения вашей проблемы.

Здесь надо через массивы... Но как хз,я в них ни але »
Из конструктивных предложений - освойте массивы (http://perfect-excel.ru/publ/excel/makrosy_i_programmy_vba/massivy_v_vba/7-1-0-74), чтобы ваша уверенность в необходимости их использования имела под собой хоть какие-то вразумительные аргументы.
Кроме того, тематических ресурсов по VBA великое множество, помнится у одного из участников подобного форума была очень подходящая к случаю подпись к сообщениям: Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы... . Набейте в любом поисковике VBA и после этого слова подпись - и обязательно найдете этот ресурс с большим количеством материала для вашего самообразования. Лично я бы уделил больше времени самой подписи в силу ее универсальности.
Ну с тремя столбцами проблему решил, однако учитывается по прежнему первое совпадение, а не все(именно совпадение,а не вхождение)... Ну и не копирует итого на новый лист.. Помогите хотя бы с этим проблему решить...
А на счёт необдимости- это простая задачка, а когда работа будет например с 1,5 млн строк в которых примерно 40 столбцов, тогда перебор увы не покатит.
Сейчас в меня полетят какашки по поводу что тут надо что то более сложное, или вооБще аксес или какую нибудь другую прогу по работе с базами данных. Но, есть только Эксель и работаем в том что есть.Как говорится не было б ограничений, все было б проще.
Вот был пример
http://www.cyberforum.ru/vba/thread1617510-page3.html

Но не знаю как к нему прикрутить столбцы

[Iska]

Из конструктивных предложений - освойте массивы, чтобы ваша уверенность в необходимости их использования имела под собой хоть какие-то вразумительные аргументы. »
У меня, помнится, ранее было ещё более конструктивное предложение — освоить базы данных :).

[a_axe]

ещё более конструктивное предложение »
Iska, ну да, по раздумью - единственное что стоило бы посоветовать в данном случае :). Однако TS отверг базы как тогда, так и ожидаемо сейчас - отредактировав свой пост №9 в этом топике ;)
Судя по всему - массивы более компромиссный вариант, правда непонятно, как они тут помогут :).

[blackeangel]

Судя по всему - массивы более компромиссный вариант, правда непонятно, как они тут помогут :).

По моему мнению(а может и заблуждению) создав массив из нужных колонок(хотя как вариант скопировав нужные колонки на новый лист) с ним будет проще работать в памяти.

На счёт того что отверг-каково задание дали мне, так я его и выложил. Не моя прихоть.
А так спасибо за лестные слова :)

[a_axe]

когда работа будет например с 1,5 млн строк в которых примерно 40 столбцов, тогда перебор увы не покатит. »
Разумеется - сделать указанную рабочую книгу просто-напросто не получится, смотрите тут (http://forum.oszone.net/thread-305615.html). Если подобрать грамотный алгоритм, будет совершенно без разницы 40 у вас колонок или 2000.
А так спасибо за лестные слова »
blackeangel, вы вполне определенно описали в первых постах проблему, приложили вполне определенные примеры, вам дали два решения. После этого оказалось, что условия совсем другие, примеры тоже не полностью отражают реальность. Потраченное на ваши проблемы время ушло в пустую только по той причине, что вам было лень грамотно расписать условия задачи (даже если ее вам поставил кто-то другой). Появится новый вариант решения - у вас вероятно появится еще одно условие, о котором ну прямо никак нельзя было сказать заранее.
Сейчас в меня полетят какашки по поводу что тут надо »
Извините - сильно комментировать не стану, только в части того, что смысл форума во многом в этом и заключается, указывать свое виденье что и каким образом лучше делать в той или иной ситуации. Слушать или нет - дело абсолютно добровольное.

В мое советское школьное детство преподаватели вбили одну незатейливую истину: правильно и грамотно оформленные условия задачи являются ровно половиной ее решения.
Что нужно делать у вас - извините, абсолютно для меня не понятно.
Ах да, и как оказалось, столбцов из базы(2 файл) надо брать 3... »
Просто здорово, что вы не указываете, какие именно столбцы и в каком порядке. Тут все просто обожают угадывать.
И располагаются они хаотично.. »
Это следует показать в примере, если необходимо - в нескольких.
учитывает только первую входимость, а надо все... »
Что такое первая входимость? Как ее нужно учитывать - записывать одинаковые строчки, или есть некий алгоритм как их различать?
Необходимо к перечню 1го файла прикрутить тот столбец что во втором файле, »
Как следует понимать слово "прикрутить"?
Еще раз терпеливо вам объясняю: отсутствие внятной постановки задачи с большой долей вероятности делает невозможным ее решение. Опишите хотя бы Ваше виденье алгоритма: "обработчик в исходном файле ищет ячейку с содержимым "Инструм.", получает номер столбца, перебирает в нем все непустые ячейки, ищет значение каждой из этих ячеек во втором файле, если нашел - копирует значения из столбцов с заголовками такими-то..." и т.д. Вы это формулируете в виде "нужно прикрутить", а что конкретно делать нужно - в общем-то не понятно.
Привожу свое интуитивное виденье кода, который вероятно вам нужен. Если вы его просто проигнорируете - как первый код, будто его и не было - возьму самоотвод от участия в этой теме. Запускать код нужно при активном документе, куда вы хотите копировать данные. Открыты д.б. оба документа.
Public Sub osn()
Dim dataBook As Workbook
Dim dataSheet As Worksheet
Dim myCell As Range
Dim i As Long, j As Long, k As Long, m As Long, n As Long
If Application.Workbooks.Count = 2 Then
For Each dataBook In Application.Workbooks
If dataBook.Name <> ThisWorkbook.Name Then Set dataSheet = dataBook.ActiveSheet

Next
i = dataSheet.Rows(1).Find(What:="№ детали", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
j = dataSheet.Rows(1).Find(What:="Инструм.", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
k = dataSheet.Rows(1).Find(What:="Год", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
m = ActiveSheet.Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
Debug.Print dataSheet.Name
Debug.Print i & " " & j & " " & k & " " & m
For Each myCell In Intersect(ActiveWorkbook.ActiveSheet.UsedRange, ActiveWorkbook.ActiveSheet.Columns(m))
On Error Resume Next
Err.Clear
n = Application.WorksheetFunction.Match(myCell.Value, Range(dataSheet.Cells(1, i), dataSheet.Cells(dataSheet.UsedRange.Count, i)), 0)
myCell.Offset(0, 1).Value = Application.WorksheetFunction.Index(Range(dataSheet.Cells(1, j), dataSheet.Cells(dataSheet.UsedRange.Count, j)), n)
myCell.Offset(0, 2).Value = Application.WorksheetFunction.Index(Range(dataSheet.Cells(1, k), dataSheet.Cells(dataSheet.UsedRange.Count, k)), n)

If Err.Number <> 0 Then
myCell.Offset(0, 1).Value = ""
myCell.Offset(0, 2).Value = ""
End If

Next
ActiveWorkbook.ActiveSheet.Cells(1, m).Value = "Обозначение"
Else
MsgBox "Должно быть открыто 2 файла."
End If
Set dataSheet = Nothing
End Sub

[blackeangel]

Итак, по коду - постоянно ругается, что не открыты 2 файла, хотя открыты оба и кроме них больше ничего.
В общем задание утряслось и есть чёткие требования. Прикладываю файлы. В первом на первом листе список, на втором итого,что должно получиться. В 2файле несколько вариантов "базы" откуда берутся данные.
Уточню ещё один момент, если имеет значение - winXP, office 2010.

[a_axe]

Итак, по коду - постоянно ругается что не открыты 2 файла, хотя открыты оба и кроме их больше ничего. »
попробуйте запустить вариант кода ниже, он перечислит по очереди все открытые файлы в сообщении.
Public Sub osn()
Dim dataBook As Workbook
Dim dataSheet As Worksheet
Dim myCell As Range
Dim i As Long, j As Long, k As Long, m As Long, n As Long, Ik As Integer
For Each dataBook In Application.Workbooks
Ik = Ik + 1
MsgBox "Открыто " & Application.Workbooks.Count & " рабочих книг, №" & Ik & " - " & dataBook.Name
Next
If Application.Workbooks.Count = 2 Then
For Each dataBook In Application.Workbooks
If dataBook.Name <> ThisWorkbook.Name Then Set dataSheet = dataBook.ActiveSheet

Next
i = dataSheet.Rows(1).Find(What:="№ детали", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
j = dataSheet.Rows(1).Find(What:="Инструм.", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
k = dataSheet.Rows(1).Find(What:="Год", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
m = ActiveSheet.Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
Debug.Print dataSheet.Name
Debug.Print i & " " & j & " " & k & " " & m
For Each myCell In Intersect(ActiveWorkbook.ActiveSheet.UsedRange, ActiveWorkbook.ActiveSheet.Columns(m))
On Error Resume Next
Err.Clear
n = Application.WorksheetFunction.Match(myCell.Value, Range(dataSheet.Cells(1, i), dataSheet.Cells(dataSheet.UsedRange.Count, i)), 0)
myCell.Offset(0, 1).Value = Application.WorksheetFunction.Index(Range(dataSheet.Cells(1, j), dataSheet.Cells(dataSheet.UsedRange.Count, j)), n)
myCell.Offset(0, 2).Value = Application.WorksheetFunction.Index(Range(dataSheet.Cells(1, k), dataSheet.Cells(dataSheet.UsedRange.Count, k)), n)

If Err.Number <> 0 Then
myCell.Offset(0, 1).Value = ""
myCell.Offset(0, 2).Value = ""
End If

Next
ActiveWorkbook.ActiveSheet.Cells(1, m).Value = "Обозначение"
Else
MsgBox "Должно быть открыто 2 файла."
End If
Set dataSheet = Nothing
End Sub

Отпишитесь по результату, сколько он показывает файлов. Либо можно определить имя файла, из которого будет выполняться копирование.

[blackeangel]

Показал верно, отработал криво, не учитывал первые строки. Осталось оформить как в примере на листе итого в предыдущем посте.

[blackeangel]

Пытался сделать из вашего кода чтобы читал из файла не получилось

Sub osn()
Dim myCell As Range
Application.ScreenUpdating = False
k = "D:\Обмен\МИПУ.xlsx"
Set s = GetObject(k)
Set i = s.Worksheets(1).Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
mckoboz = i.Column
Set j = s.Worksheets(1).Rows(1).Find(What:="Маршрут", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
mck = j.Column
Set m = ActiveSheet.Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
dceoboz = m.Column

For Each myCell In Intersect(ActiveWorkbook.ActiveSheet.UsedRange, s.Worksheets(1).Columns(dceoboz))
On Error Resume Next
n = Application.WorksheetFunction.Match(myCell.Value, Range(s.Worksheets(1).Cells(1, mckoboz), s.Worksheets(1).Cells(s.Worksheets(1).UsedRange.Count, mckoboz)), 0)
myCell.Offset(0, 1).Value = Application.WorksheetFunction.Index(Range(s.Worksheets(1).Cells(1, mck), s.Worksheets(1).Cells(s.Worksheets(1).UsedRange.Count, mck)), n)
Next
s.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub

Где накосячил?