Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Cоединить две таблица по частичному вхождению - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Cоединить две таблица по частичному вхождению (Макросы/Sub)
Cоединить две таблица по частичному вхождению
Dartray Дата: Четверг, 09.02.2017, 00:23 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Очень не хотел создавать но тему, но решения в интернете/на форуме не нашел.

Имеем две таблицы:

1-ая содержит столбец "C" вида <БРЕНД><МОДЕЛЬ>
2-ая содержит столбец "А" вида <БРЕНД><МОДЕЛЬ><какой-то текст>

Необходимо для всех найденных вхождений значений столбца C из первой таблицы скопировать данные столбцов C, D, E,...,Q второй таблицы.

Все оставшиеся позиции, для которых вхождение не найдено, вставить новыми строками (второстепенно).
К сообщению приложен файл: table_01.xlsx (40.9 Kb) · table_02.xlsx (18.3 Kb)
 
Ответить
СообщениеОчень не хотел создавать но тему, но решения в интернете/на форуме не нашел.

Имеем две таблицы:

1-ая содержит столбец "C" вида <БРЕНД><МОДЕЛЬ>
2-ая содержит столбец "А" вида <БРЕНД><МОДЕЛЬ><какой-то текст>

Необходимо для всех найденных вхождений значений столбца C из первой таблицы скопировать данные столбцов C, D, E,...,Q второй таблицы.

Все оставшиеся позиции, для которых вхождение не найдено, вставить новыми строками (второстепенно).

Автор - Dartray
Дата добавления - 09.02.2017 в 00:23
Kamikadze_N Дата: Четверг, 09.02.2017, 09:40 | Сообщение № 2
Группа: Пользователи
Ранг: Участник
Сообщений: 75
Репутация: 6 ±
Замечаний: 0% ±

Excel 2010
как вариант, цикл в цикле. Типо перебор всех элементов первой таблицы по столбцу С, сравниваем со всеми элементами Второй таблицы столбца 1. Сравнивайте хоть через InStr (так проще). Или находите длинну значения в ячейке С, далее через Left и найденной длины значение в ячейке А сравниваем. Далее при совпадении значений Добавляем значения из нужного диапазона, в противном случае, находим первую не пустую ячейку в столбце С и вставляем туда всю строку из второй таблицы. Закончить цикл, закончить цикл. Я бы как то так сделал. Только сначала все это лучше в массив загнать. То есть значения из ячейки С и значения из значейки А во второй. И сравнивать непосредственно массивы, и только потом уже значения из таблицы в другую таблицу перекидывать, что бы время работы макроса сократить.
Что то похожее вот в этом примере я описывал. У вас алгаритм такой же будет, только условие поиска как я писал выше изменить.
My WebPage


Сообщение отредактировал Kamikadze_N - Четверг, 09.02.2017, 09:45
 
Ответить
Сообщениекак вариант, цикл в цикле. Типо перебор всех элементов первой таблицы по столбцу С, сравниваем со всеми элементами Второй таблицы столбца 1. Сравнивайте хоть через InStr (так проще). Или находите длинну значения в ячейке С, далее через Left и найденной длины значение в ячейке А сравниваем. Далее при совпадении значений Добавляем значения из нужного диапазона, в противном случае, находим первую не пустую ячейку в столбце С и вставляем туда всю строку из второй таблицы. Закончить цикл, закончить цикл. Я бы как то так сделал. Только сначала все это лучше в массив загнать. То есть значения из ячейки С и значения из значейки А во второй. И сравнивать непосредственно массивы, и только потом уже значения из таблицы в другую таблицу перекидывать, что бы время работы макроса сократить.
Что то похожее вот в этом примере я описывал. У вас алгаритм такой же будет, только условие поиска как я писал выше изменить.
My WebPage

Автор - Kamikadze_N
Дата добавления - 09.02.2017 в 09:40
Kamikadze_N Дата: Четверг, 09.02.2017, 10:34 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 75
Репутация: 6 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код
Sub sFind()
Dim ArrC() As String
Dim ArrA() As String

xRow = 2
Do While Worksheets("article_all_5").Cells(xRow, 3) <> ""
    K = K + 1
    ReDim Preserve ArrC(1 To K)
    ArrC(K) = Worksheets("article_all_5").Cells(xRow, 3)

    xRow = xRow + 1
Loop

xRow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual 'xlCalculationManual
Workbooks.Open ThisWorkbook.Path & "\table_02"
Do While Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(xRow, 1) <> ""
    N = N + 1
    ReDim Preserve ArrA(1 To N)
    ArrA(N) = Worksheets("article_all_6").Cells(xRow, 1)
    xRow = xRow + 1
Loop

For i = 1 To K
    For j = 1 To N
        If ArrC(i) = Left(ArrA(j), Len(ArrC(i))) Then
            Workbooks("table_01.xlsx").Worksheets("article_all_5").Cells(i+1, Например 5) = Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(j+1, 5)
            'и так сколько угодно строк с соответствующими столбцами одного листа другому
            ...
End Sub
[/vba]
вот как то так вставку производить, я просто не понял какой столбец у вас какому соответствовать должен,
а что касается добавления если совпадения не найдены, то наоборот
[vba]
Код

For i = 1 To K
    For j = 1 To N
        If Left(ArrA(i), Len(ArrC(j))) = ArrC(j) Then
            sch = 1
        End If
    Next
    If sch <> 1 Then
'поиск первой пустой строки в первой таблице
    xRow = 2
    Do While Worksheets("article_all_5").Cells(xRow, 3) <> ""
    xRow = xRow + 1
    Loop
    'вставка элементов
    Workbooks("table_01.xlsx").Worksheets("article_all_5").Cells(xRow, Íàïðèìåð 5) = Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(i, 5)
    'аналогичная вставка
next
[/vba]

по аналогии допишите сами , или если не понятно то уточните какой столбец во второй таблице должен соответствовать столбцу в первой таблице


Сообщение отредактировал Kamikadze_N - Четверг, 09.02.2017, 10:36
 
Ответить
Сообщение[vba]
Код
Sub sFind()
Dim ArrC() As String
Dim ArrA() As String

xRow = 2
Do While Worksheets("article_all_5").Cells(xRow, 3) <> ""
    K = K + 1
    ReDim Preserve ArrC(1 To K)
    ArrC(K) = Worksheets("article_all_5").Cells(xRow, 3)

    xRow = xRow + 1
Loop

xRow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual 'xlCalculationManual
Workbooks.Open ThisWorkbook.Path & "\table_02"
Do While Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(xRow, 1) <> ""
    N = N + 1
    ReDim Preserve ArrA(1 To N)
    ArrA(N) = Worksheets("article_all_6").Cells(xRow, 1)
    xRow = xRow + 1
Loop

For i = 1 To K
    For j = 1 To N
        If ArrC(i) = Left(ArrA(j), Len(ArrC(i))) Then
            Workbooks("table_01.xlsx").Worksheets("article_all_5").Cells(i+1, Например 5) = Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(j+1, 5)
            'и так сколько угодно строк с соответствующими столбцами одного листа другому
            ...
End Sub
[/vba]
вот как то так вставку производить, я просто не понял какой столбец у вас какому соответствовать должен,
а что касается добавления если совпадения не найдены, то наоборот
[vba]
Код

For i = 1 To K
    For j = 1 To N
        If Left(ArrA(i), Len(ArrC(j))) = ArrC(j) Then
            sch = 1
        End If
    Next
    If sch <> 1 Then
'поиск первой пустой строки в первой таблице
    xRow = 2
    Do While Worksheets("article_all_5").Cells(xRow, 3) <> ""
    xRow = xRow + 1
    Loop
    'вставка элементов
    Workbooks("table_01.xlsx").Worksheets("article_all_5").Cells(xRow, Íàïðèìåð 5) = Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(i, 5)
    'аналогичная вставка
next
[/vba]

по аналогии допишите сами , или если не понятно то уточните какой столбец во второй таблице должен соответствовать столбцу в первой таблице

Автор - Kamikadze_N
Дата добавления - 09.02.2017 в 10:34
K-SerJC Дата: Четверг, 09.02.2017, 11:21 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 487
Репутация: 86 ±
Замечаний: 0% ±

Excel 2013
а если так?
К сообщению приложен файл: Dartray.xlsm (66.7 Kb)


Благими намерениями выстелена дорога в АД.
 
Ответить
Сообщениеа если так?

Автор - K-SerJC
Дата добавления - 09.02.2017 в 11:21
Gustav Дата: Четверг, 09.02.2017, 14:04 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2695
Репутация: 1123 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
Мой вариант для получения совпадений - с использованием SQL для исполнения в Окне отладки (файл Dartray.xlsm из предыдущего поста №4 предварительно надо сохранить на диске и создать в нём лист Лист1):
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): _
rst.Open "SELECT * FROM [table1$] AS t1, [table2$] AS t2 " _
& " WHERE t2.Наименование Like t1.[Бренд+Модель] & '%'", _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0;HDR=Yes'": _
[Лист1!A2].CopyFromRecordset rst
[/vba]Просто скопировать в Окно отладки и нажать Enter. В результате на листе Лист1, начиная с А2 - список совпадений по неполному значению (выводятся все колонки обеих таблиц, заголовки можно скопировать вручную). При желании можно оформить в виде нормального макроса.

Ранее подобный трюк с Окном отладки был представлен здесь. Сам запрос SQL был предварительно "написан" и отлажен в MS Access.

P.S. До кучи - два запроса для получения оставшихся (несовпадающих) записей из обеих таблиц. Запросы "заточены" на два новых листа (Лист2 и Лист3), которые следует добавить в рабочую книгу.

Несовпадающие записи из 1-й таблицы - 38 штук на Лист2:
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): _
rst.Open "SELECT * FROM [table1$] " _
& " WHERE [Бренд+Модель] Not In (SELECT DISTINCT t1.[Бренд+Модель] FROM [table1$] AS t1, [table2$] AS t2 WHERE t2.Наименование Like t1.[Бренд+Модель] & '%')", _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0;HDR=Yes'": _
[Лист2!A2].CopyFromRecordset rst
[/vba]

Несовпадающие записи из 2-й таблицы - 9 штук на Лист3:
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): _
rst.Open "SELECT * FROM [table2$] " _
& " WHERE Наименование Not In (SELECT DISTINCT t2.Наименование FROM [table1$] AS t1, [table2$] AS t2 WHERE t2.Наименование Like t1.[Бренд+Модель] & '%')", _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0;HDR=Yes'": _
[Лист3!A2].CopyFromRecordset rst
[/vba]


МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Четверг, 09.02.2017, 14:23
 
Ответить
СообщениеМой вариант для получения совпадений - с использованием SQL для исполнения в Окне отладки (файл Dartray.xlsm из предыдущего поста №4 предварительно надо сохранить на диске и создать в нём лист Лист1):
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): _
rst.Open "SELECT * FROM [table1$] AS t1, [table2$] AS t2 " _
& " WHERE t2.Наименование Like t1.[Бренд+Модель] & '%'", _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0;HDR=Yes'": _
[Лист1!A2].CopyFromRecordset rst
[/vba]Просто скопировать в Окно отладки и нажать Enter. В результате на листе Лист1, начиная с А2 - список совпадений по неполному значению (выводятся все колонки обеих таблиц, заголовки можно скопировать вручную). При желании можно оформить в виде нормального макроса.

Ранее подобный трюк с Окном отладки был представлен здесь. Сам запрос SQL был предварительно "написан" и отлажен в MS Access.

P.S. До кучи - два запроса для получения оставшихся (несовпадающих) записей из обеих таблиц. Запросы "заточены" на два новых листа (Лист2 и Лист3), которые следует добавить в рабочую книгу.

Несовпадающие записи из 1-й таблицы - 38 штук на Лист2:
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): _
rst.Open "SELECT * FROM [table1$] " _
& " WHERE [Бренд+Модель] Not In (SELECT DISTINCT t1.[Бренд+Модель] FROM [table1$] AS t1, [table2$] AS t2 WHERE t2.Наименование Like t1.[Бренд+Модель] & '%')", _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0;HDR=Yes'": _
[Лист2!A2].CopyFromRecordset rst
[/vba]

Несовпадающие записи из 2-й таблицы - 9 штук на Лист3:
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): _
rst.Open "SELECT * FROM [table2$] " _
& " WHERE Наименование Not In (SELECT DISTINCT t2.Наименование FROM [table1$] AS t1, [table2$] AS t2 WHERE t2.Наименование Like t1.[Бренд+Модель] & '%')", _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0;HDR=Yes'": _
[Лист3!A2].CopyFromRecordset rst
[/vba]

Автор - Gustav
Дата добавления - 09.02.2017 в 14:04
Dartray Дата: Четверг, 09.02.2017, 17:56 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Kamikadze_N, спасибо. Судя по всему в первом макросе не хватает End if, и next для обоих переменных.
Попробовал дописать сам.

[vba]
Код

Sub sFind()
Dim ArrC() As String
Dim ArrA() As String

xRow = 2
Do While Worksheets("article_all_5").Cells(xRow, 3) <> ""
K = K + 1
ReDim Preserve ArrC(1 To K)
ArrC(K) = Worksheets("article_all_5").Cells(xRow, 3)

xRow = xRow + 1
Loop

xRow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual 'xlCalculationManual
Workbooks.Open ThisWorkbook.Path & "\table_02"
Do While Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(xRow, 1) <> ""
N = N + 1
ReDim Preserve ArrA(1 To N)
ArrA(N) = Worksheets("article_all_6").Cells(xRow, 1)
xRow = xRow + 1
Loop

For i = 1 To K
For j = 1 To N
If ArrC(i) = Left(ArrA(j), Len(ArrC(i))) Then
Workbooks("table_01.xlsx").Worksheets("article_all_5").Cells(i + 1, 5) = Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(j + 1, 5)
'и так сколько угодно строк с соответствующими столбцами одного листа другому
End If
Next j
Next i
End Sub
[/vba]

Но в итоге ничего не получилось((

K-SerJC, Gustav, спасибо!
Так, но не совсем.

Результатом должна быть таблица, содержащая колонки обеих исходных таблиц.
Т.е. для найденных значений добавить в конец первой таблицы информацию из колонок C, D, E,...,Q второй таблицы.

Какие же всё-таки отзывчивые люди на этом форуме! hands


Сообщение отредактировал Dartray - Четверг, 09.02.2017, 17:57
 
Ответить
СообщениеKamikadze_N, спасибо. Судя по всему в первом макросе не хватает End if, и next для обоих переменных.
Попробовал дописать сам.

[vba]
Код

Sub sFind()
Dim ArrC() As String
Dim ArrA() As String

xRow = 2
Do While Worksheets("article_all_5").Cells(xRow, 3) <> ""
K = K + 1
ReDim Preserve ArrC(1 To K)
ArrC(K) = Worksheets("article_all_5").Cells(xRow, 3)

xRow = xRow + 1
Loop

xRow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual 'xlCalculationManual
Workbooks.Open ThisWorkbook.Path & "\table_02"
Do While Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(xRow, 1) <> ""
N = N + 1
ReDim Preserve ArrA(1 To N)
ArrA(N) = Worksheets("article_all_6").Cells(xRow, 1)
xRow = xRow + 1
Loop

For i = 1 To K
For j = 1 To N
If ArrC(i) = Left(ArrA(j), Len(ArrC(i))) Then
Workbooks("table_01.xlsx").Worksheets("article_all_5").Cells(i + 1, 5) = Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(j + 1, 5)
'и так сколько угодно строк с соответствующими столбцами одного листа другому
End If
Next j
Next i
End Sub
[/vba]

Но в итоге ничего не получилось((

K-SerJC, Gustav, спасибо!
Так, но не совсем.

Результатом должна быть таблица, содержащая колонки обеих исходных таблиц.
Т.е. для найденных значений добавить в конец первой таблицы информацию из колонок C, D, E,...,Q второй таблицы.

Какие же всё-таки отзывчивые люди на этом форуме! hands

Автор - Dartray
Дата добавления - 09.02.2017 в 17:56
Gustav Дата: Четверг, 09.02.2017, 18:24 | Сообщение № 7
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2695
Репутация: 1123 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
Результатом должна быть таблица, содержащая колонки обеих исходных таблиц

У меня первый запрос содержит колонки обеих таблиц.

Второй и третий - колонки только одной таблицы (по понятным причинам).


МОИ: Ник, Tip box: 41001663842605
 
Ответить
Сообщение
Результатом должна быть таблица, содержащая колонки обеих исходных таблиц

У меня первый запрос содержит колонки обеих таблиц.

Второй и третий - колонки только одной таблицы (по понятным причинам).

Автор - Gustav
Дата добавления - 09.02.2017 в 18:24
Kamikadze_N Дата: Четверг, 09.02.2017, 18:30 | Сообщение № 8
Группа: Пользователи
Ранг: Участник
Сообщений: 75
Репутация: 6 ±
Замечаний: 0% ±

Excel 2010
Dartray, так вы вторую то часть кода допише себя ниже[vba]
Код
For i = 1 To K
    For j = 1 To N
        If Left(ArrA(i), Len(ArrC(j))) = ArrC(j) Then
            sch = 1
        End If
    Next
    If sch <> 1 Then
'поиск первой пустой строки в первой таблице
    xRow = 2
    Do While Worksheets("article_all_5").Cells(xRow, 3) <> ""
    xRow = xRow + 1
    Loop
    'вставка элементов
    Workbooks("table_01.xlsx").Worksheets("article_all_5").Cells(xRow, Íàïðèìåð 5) = Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(i, 5)
    'аналогичная вставка
next
[/vba]
что бы процедура полностью отработала или укажите в первом листе куда перенести столбцы из второго столбца соответственно и я допишу сам соответствия
 
Ответить
СообщениеDartray, так вы вторую то часть кода допише себя ниже[vba]
Код
For i = 1 To K
    For j = 1 To N
        If Left(ArrA(i), Len(ArrC(j))) = ArrC(j) Then
            sch = 1
        End If
    Next
    If sch <> 1 Then
'поиск первой пустой строки в первой таблице
    xRow = 2
    Do While Worksheets("article_all_5").Cells(xRow, 3) <> ""
    xRow = xRow + 1
    Loop
    'вставка элементов
    Workbooks("table_01.xlsx").Worksheets("article_all_5").Cells(xRow, Íàïðèìåð 5) = Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(i, 5)
    'аналогичная вставка
next
[/vba]
что бы процедура полностью отработала или укажите в первом листе куда перенести столбцы из второго столбца соответственно и я допишу сам соответствия

Автор - Kamikadze_N
Дата добавления - 09.02.2017 в 18:30
Kamikadze_N Дата: Четверг, 09.02.2017, 18:30 | Сообщение № 9
Группа: Пользователи
Ранг: Участник
Сообщений: 75
Репутация: 6 ±
Замечаний: 0% ±

Excel 2010
Dartray, так вы вторую то часть кода допише себя ниже[vba]
Код
For i = 1 To K
    For j = 1 To N
        If Left(ArrA(i), Len(ArrC(j))) = ArrC(j) Then
            sch = 1
        End If
    Next
    If sch <> 1 Then
'поиск первой пустой строки в первой таблице
    xRow = 2
    Do While Worksheets("article_all_5").Cells(xRow, 3) <> ""
    xRow = xRow + 1
    Loop
    'вставка элементов
    Workbooks("table_01.xlsx").Worksheets("article_all_5").Cells(xRow, Íàïðèìåð 5) = Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(i, 5)
    'аналогичная вставка
next
[/vba]
что бы процедура полностью отработала или укажите в первом листе куда перенести столбцы из второго столбца соответственно и я допишу сам соответствия
 
Ответить
СообщениеDartray, так вы вторую то часть кода допише себя ниже[vba]
Код
For i = 1 To K
    For j = 1 To N
        If Left(ArrA(i), Len(ArrC(j))) = ArrC(j) Then
            sch = 1
        End If
    Next
    If sch <> 1 Then
'поиск первой пустой строки в первой таблице
    xRow = 2
    Do While Worksheets("article_all_5").Cells(xRow, 3) <> ""
    xRow = xRow + 1
    Loop
    'вставка элементов
    Workbooks("table_01.xlsx").Worksheets("article_all_5").Cells(xRow, Íàïðèìåð 5) = Workbooks("table_02.xlsx").Worksheets("article_all_6").Cells(i, 5)
    'аналогичная вставка
next
[/vba]
что бы процедура полностью отработала или укажите в первом листе куда перенести столбцы из второго столбца соответственно и я допишу сам соответствия

Автор - Kamikadze_N
Дата добавления - 09.02.2017 в 18:30
Gustav Дата: Четверг, 09.02.2017, 18:34 | Сообщение № 10
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2695
Репутация: 1123 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
В дополнение к моим вышеприведенным "формулам".

Давненько смотрю на этот "радикал":
[vba]
Код
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0;HDR=Yes'": _
[/vba]- так и хочется его куда-нибудь засунуть с глаз долой. Всё остальное так компактно и симпатично получается, а радикал слегка подводит...

Решение, наконец, "проочевиделось" сегодня, благодаря этой теме - с помощью имени, создаваемого по Ctrl+F3, т.е. с помощью "Диспетчера имён" рабочей книги.

Создадим коротенькое имя src (от "source" - источник) и назначим ему в поле "Диапазон" такую формулу, по сути вычисляющую наш радикал:
Код
="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='"&ПОДСТАВИТЬ(ЛЕВСИМВ(ЯЧЕЙКА("имяфайла");ПОИСК("]";ЯЧЕЙКА("имяфайла"))-1);"[";)&"';Extended Properties='Excel 12.0;HDR=Yes'"


И далее дерзко упростим наш первый составной оператор для Окна отладки:
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): rst.Open _
"SELECT * FROM [table1$] AS t1, [table2$] AS t2" & _
" WHERE t2.Наименование Like t1.[Бренд+Модель]&'%'" _
,[src]: [Лист1!A2].CopyFromRecordset rst
[/vba]
А?!

Если запрос достаточно короткий, то его можно разместить и на одной строке, не перенося оператор WHERE на другую:
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): rst.Open _
"SELECT * FROM [table1$] t1, [table2$] t2 WHERE t2.Наименование Like t1.[Бренд+Модель]&'%'" _
,[src]: [Лист1!A2].CopyFromRecordset rst
[/vba]

В целом, подход вырисовывается такой: берем этот 3-х строчный шаблон, придаем нужный вид адресу вставки [Лист1!A2] и творим запрос SQL во второй строке.

Конечно, сложные запросы для наглядности лучше размещать на нескольких строках. Сформатируем по-другому второй и третий запрос из предыдущего поста (№ 5):
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): rst.Open _
"SELECT * FROM [table1$] WHERE [Бренд+Модель] Not In" & _
" (SELECT DISTINCT t1.[Бренд+Модель] FROM [table1$] t1, [table2$] t2" & _
"  WHERE t2.Наименование Like t1.[Бренд+Модель] & '%')" _
,[src]: [Лист2!A2].CopyFromRecordset rst
[/vba]
Можно даже выделить запрос с помощью "пустых" строк (пробел+подчерк):
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): rst.Open _
_
"SELECT * FROM [table2$] WHERE Наименование Not In" & _
" (SELECT DISTINCT t2.Наименование" & _
"  FROM [table1$] t1, [table2$] t2" & _
"  WHERE t2.Наименование Like t1.[Бренд+Модель] & '%')" _
_
,[src]: ['Лист 3'!A2].CopyFromRecordset rst
[/vba]
(тэг vba съел ведущие пробелы перед подчерком во 2-й и 7-й строке, но при исполнении они там должны присутствовать! - можно добавить вручную в Окне отладки)


МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Четверг, 09.02.2017, 19:06
 
Ответить
СообщениеВ дополнение к моим вышеприведенным "формулам".

Давненько смотрю на этот "радикал":
[vba]
Код
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0;HDR=Yes'": _
[/vba]- так и хочется его куда-нибудь засунуть с глаз долой. Всё остальное так компактно и симпатично получается, а радикал слегка подводит...

Решение, наконец, "проочевиделось" сегодня, благодаря этой теме - с помощью имени, создаваемого по Ctrl+F3, т.е. с помощью "Диспетчера имён" рабочей книги.

Создадим коротенькое имя src (от "source" - источник) и назначим ему в поле "Диапазон" такую формулу, по сути вычисляющую наш радикал:
Код
="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='"&ПОДСТАВИТЬ(ЛЕВСИМВ(ЯЧЕЙКА("имяфайла");ПОИСК("]";ЯЧЕЙКА("имяфайла"))-1);"[";)&"';Extended Properties='Excel 12.0;HDR=Yes'"


И далее дерзко упростим наш первый составной оператор для Окна отладки:
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): rst.Open _
"SELECT * FROM [table1$] AS t1, [table2$] AS t2" & _
" WHERE t2.Наименование Like t1.[Бренд+Модель]&'%'" _
,[src]: [Лист1!A2].CopyFromRecordset rst
[/vba]
А?!

Если запрос достаточно короткий, то его можно разместить и на одной строке, не перенося оператор WHERE на другую:
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): rst.Open _
"SELECT * FROM [table1$] t1, [table2$] t2 WHERE t2.Наименование Like t1.[Бренд+Модель]&'%'" _
,[src]: [Лист1!A2].CopyFromRecordset rst
[/vba]

В целом, подход вырисовывается такой: берем этот 3-х строчный шаблон, придаем нужный вид адресу вставки [Лист1!A2] и творим запрос SQL во второй строке.

Конечно, сложные запросы для наглядности лучше размещать на нескольких строках. Сформатируем по-другому второй и третий запрос из предыдущего поста (№ 5):
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): rst.Open _
"SELECT * FROM [table1$] WHERE [Бренд+Модель] Not In" & _
" (SELECT DISTINCT t1.[Бренд+Модель] FROM [table1$] t1, [table2$] t2" & _
"  WHERE t2.Наименование Like t1.[Бренд+Модель] & '%')" _
,[src]: [Лист2!A2].CopyFromRecordset rst
[/vba]
Можно даже выделить запрос с помощью "пустых" строк (пробел+подчерк):
[vba]
Код
Set rst = CreateObject("ADODB.Recordset"): rst.Open _
_
"SELECT * FROM [table2$] WHERE Наименование Not In" & _
" (SELECT DISTINCT t2.Наименование" & _
"  FROM [table1$] t1, [table2$] t2" & _
"  WHERE t2.Наименование Like t1.[Бренд+Модель] & '%')" _
_
,[src]: ['Лист 3'!A2].CopyFromRecordset rst
[/vba]
(тэг vba съел ведущие пробелы перед подчерком во 2-й и 7-й строке, но при исполнении они там должны присутствовать! - можно добавить вручную в Окне отладки)

Автор - Gustav
Дата добавления - 09.02.2017 в 18:34
Dartray Дата: Четверг, 09.02.2017, 19:36 | Сообщение № 11
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Kamikadze_N,
столбцы 3-17 второй таблицы
в
столбцы 20-34 первой таблицы
соответственно

Gustav,
да, действительно все столбцы есть. извиняюсь, проглядел.

по поводу оптимизации:
не совсем понял где создавать имя src

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

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

картинка для наглядности. "X" - номер строки, в котором нашлось соответствие.
К сообщению приложен файл: 5731563.png (239.3 Kb)
 
Ответить
СообщениеKamikadze_N,
столбцы 3-17 второй таблицы
в
столбцы 20-34 первой таблицы
соответственно

Gustav,
да, действительно все столбцы есть. извиняюсь, проглядел.

по поводу оптимизации:
не совсем понял где создавать имя src

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

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

картинка для наглядности. "X" - номер строки, в котором нашлось соответствие.

Автор - Dartray
Дата добавления - 09.02.2017 в 19:36
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Cоединить две таблица по частичному вхождению (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!