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

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

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

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

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

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

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

Код:

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

Реализовать надо в макросе.. »

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

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

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

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

Цитата:

Цитата a_axe (Сообщение 2599536)

Цитата:

Цитата blackeangel

Реализовать надо в макросе.. »

Увы, нужен именно макрос

Цитата:

Цитата blackeangel

нужен именно макрос »

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

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

Скрытый текст

Код:

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

Цитата:

Цитата blackeangel

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

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

Цитата:

Цитата blackeangel

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

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

Цитата:

Цитата a_axe (Сообщение 2600955)

Цитата:

Цитата blackeangel

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

Цитата:

Цитата blackeangel

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

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

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

Цитата:

Цитата a_axe

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

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

Цитата:

Цитата Iska

ещё более конструктивное предложение »

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

Цитата:

Цитата a_axe (Сообщение 2601434)

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

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

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

Оффтоп

Цитата:

Цитата blackeangel

когда работа будет например с 1,5 млн строк в которых примерно 40 столбцов, тогда перебор увы не покатит. »

Разумеется - сделать указанную рабочую книгу просто-напросто не получится, смотрите тут. Если подобрать грамотный алгоритм, будет совершенно без разницы 40 у вас колонок или 2000.

Цитата:

Цитата blackeangel

А так спасибо за лестные слова »

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

Цитата:

Цитата blackeangel

Сейчас в меня полетят какашки по поводу что тут надо »

Извините - сильно комментировать не стану, только в части того, что смысл форума во многом в этом и заключается, указывать свое виденье что и каким образом лучше делать в той или иной ситуации. Слушать или нет - дело абсолютно добровольное.

В мое советское школьное детство преподаватели вбили одну незатейливую истину: правильно и грамотно оформленные условия задачи являются ровно половиной ее решения.
Что нужно делать у вас - извините, абсолютно для меня не понятно.

Цитата:

Цитата blackeangel

Ах да, и как оказалось, столбцов из базы(2 файл) надо брать 3... »

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

Цитата:

Цитата blackeangel

И располагаются они хаотично.. »

Это следует показать в примере, если необходимо - в нескольких.

Цитата:

Цитата blackeangel

учитывает только первую входимость, а надо все... »

Что такое первая входимость? Как ее нужно учитывать - записывать одинаковые строчки, или есть некий алгоритм как их различать?

Цитата:

Цитата blackeangel

Необходимо к перечню 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

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

Цитата:

Цитата blackeangel

Итак, по коду - постоянно ругается что не открыты 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

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

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

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

Код:

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

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