[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... И располагаются они хаотично.. »

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

Здесь надо через массивы... Но как хз,я в них ни але »

Из конструктивных предложений - освойте массивы, чтобы ваша уверенность в необходимости их использования имела под собой хоть какие-то вразумительные аргументы.
Кроме того, тематических ресурсов по VBA великое множество, помнится у одного из участников подобного форума была очень подходящая к случаю подпись к сообщениям: Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы... . Набейте в любом поисковике VBA и после этого слова подпись - и обязательно найдете этот ресурс с большим количеством материала для вашего самообразования. Лично я бы уделил больше времени самой подписи в силу ее универсальности.

[blackeangel]

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

Ну с тремя столбцами проблему решил, однако учитывается по прежнему первое совпадение, а не все(именно совпадение,а не вхождение)... Ну и не копирует итого на новый лист.. Помогите хотя бы с этим проблему решить...
А на счёт необдимости- это простая задачка, а когда работа будет например с 1,5 млн строк в которых примерно 40 столбцов, тогда перебор увы не покатит.
Сейчас в меня полетят какашки по поводу что тут надо что то более сложное, или вооБще аксес или какую нибудь другую прогу по работе с базами данных. Но, есть только Эксель и работаем в том что есть.Как говорится не было б ограничений, все было б проще.
Вот был пример
http://www.cyberforum.ru/vba/thread1617510-page3.html

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

[Iska]

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

У меня, помнится, ранее было ещё более конструктивное предложение — освоить базы данных .