Не нашел моего примера, есть только сравнение таблиц при одинаковом значении.
На форме имеется два листбокса. На верхнем (Л1) то что уже есть, а на нижнем (нужно сделать) то что осталось, т.е (Л2-Л1). Не получается сформировать нижний листбокс.
[vba]
Код
Option Explicit
'Л1 Dim ЛЛ1 As Worksheet ' Лист Dim ТЛ1 As ListObject ' Таблица Dim СЛ1 As ListRow ' Строка
'Л2 Dim ЛЛ2 As Worksheet ' Лист Dim ТЛ2 As ListObject ' Таблица Dim СЛ2 As ListRow ' Строка
Sub Добавить() Add.Show End Sub Sub СформироватьСписки()
Dim a As Range Dim b As Range
Set ЛЛ1 = ThisWorkbook.Worksheets("Л1") Set ТЛ1 = ЛЛ1.ListObjects("тб_Мое") Set ЛЛ2 = ThisWorkbook.Worksheets("Л2") Set ТЛ2 = ЛЛ2.ListObjects("тб_Все") ' очистка Add.lb_all.Clear Add.lb_add.Clear Add.lb_all.ColumnWidths = "200,700" Add.lb_add.ColumnWidths = "200,700" ' заполнение верха Листбокса For Each СЛ1 In ТЛ1.ListRows Add.lb_all.AddItem СЛ1.Range(1) Add.lb_all.List(Add.lb_all.ListCount - 1, 1) = СЛ1.Range(2) Next СЛ1 ------------------------------------------------------------------------------- Тут загвоска ' заполенние низа Листбокса
For Each СЛ2 In ТЛ2.ListRows Set a = ТЛ2.ListColumns.Item(2).Range.Find(СЛ2.Range(2), , , xlWhole)
For Each СЛ1 In ТЛ1.ListRows Set b = ТЛ1.ListColumns.Item(2).Range.Find(СЛ1.Range(2), , , xlWhole) If Not a Like b Then ' если не найден артикуул Add.lb_add.AddItem СЛ2.Range(1) Add.lb_add.List(Add.lb_add.ListCount - 1, 1) = СЛ2.Range(2) ElseIf СЛ1.Range(2) Like СЛ2.Range(2) Then Exit For End If
Next СЛ1 Next СЛ2
--------------------------------------------------------------------------- End Sub
[/vba]
Не нашел моего примера, есть только сравнение таблиц при одинаковом значении.
На форме имеется два листбокса. На верхнем (Л1) то что уже есть, а на нижнем (нужно сделать) то что осталось, т.е (Л2-Л1). Не получается сформировать нижний листбокс.
[vba]
Код
Option Explicit
'Л1 Dim ЛЛ1 As Worksheet ' Лист Dim ТЛ1 As ListObject ' Таблица Dim СЛ1 As ListRow ' Строка
'Л2 Dim ЛЛ2 As Worksheet ' Лист Dim ТЛ2 As ListObject ' Таблица Dim СЛ2 As ListRow ' Строка
Sub Добавить() Add.Show End Sub Sub СформироватьСписки()
Dim a As Range Dim b As Range
Set ЛЛ1 = ThisWorkbook.Worksheets("Л1") Set ТЛ1 = ЛЛ1.ListObjects("тб_Мое") Set ЛЛ2 = ThisWorkbook.Worksheets("Л2") Set ТЛ2 = ЛЛ2.ListObjects("тб_Все") ' очистка Add.lb_all.Clear Add.lb_add.Clear Add.lb_all.ColumnWidths = "200,700" Add.lb_add.ColumnWidths = "200,700" ' заполнение верха Листбокса For Each СЛ1 In ТЛ1.ListRows Add.lb_all.AddItem СЛ1.Range(1) Add.lb_all.List(Add.lb_all.ListCount - 1, 1) = СЛ1.Range(2) Next СЛ1 ------------------------------------------------------------------------------- Тут загвоска ' заполенние низа Листбокса
For Each СЛ2 In ТЛ2.ListRows Set a = ТЛ2.ListColumns.Item(2).Range.Find(СЛ2.Range(2), , , xlWhole)
For Each СЛ1 In ТЛ1.ListRows Set b = ТЛ1.ListColumns.Item(2).Range.Find(СЛ1.Range(2), , , xlWhole) If Not a Like b Then ' если не найден артикуул Add.lb_add.AddItem СЛ2.Range(1) Add.lb_add.List(Add.lb_add.ListCount - 1, 1) = СЛ2.Range(2) ElseIf СЛ1.Range(2) Like СЛ2.Range(2) Then Exit For End If
Next СЛ1 Next СЛ2
--------------------------------------------------------------------------- End Sub
Sub СформироватьСписки() Dim arrL1(), arrL2(), arrAll Dim I&, N&, iTemp arrL1 = Worksheets("Л1").ListObjects("тб_Мое").DataBodyRange.Value arrAll = Worksheets("Л2").ListObjects("тб_Все").DataBodyRange.Value N = 1 With CreateObject("Scripting.Dictionary") For I = 1 To UBound(arrL1): iTemp = .Item(arrL1(I, 1) & arrL1(I, 2)): Next For I = 1 To UBound(arrAll) If Not .Exists(arrAll(I, 1) & arrAll(I, 2)) Then ReDim Preserve arrL2(1 To 2, 1 To N) arrL2(1, N) = arrAll(I, 1) arrL2(2, N) = arrAll(I, 2) N = N + 1 End If Next End With With Add .lb_all.List = arrL1 .lb_add.List = Application.Transpose(arrL2) End With End Sub
[/vba]
Всем спасибо. [vba]
Код
Sub СформироватьСписки() Dim arrL1(), arrL2(), arrAll Dim I&, N&, iTemp arrL1 = Worksheets("Л1").ListObjects("тб_Мое").DataBodyRange.Value arrAll = Worksheets("Л2").ListObjects("тб_Все").DataBodyRange.Value N = 1 With CreateObject("Scripting.Dictionary") For I = 1 To UBound(arrL1): iTemp = .Item(arrL1(I, 1) & arrL1(I, 2)): Next For I = 1 To UBound(arrAll) If Not .Exists(arrAll(I, 1) & arrAll(I, 2)) Then ReDim Preserve arrL2(1 To 2, 1 To N) arrL2(1, N) = arrAll(I, 1) arrL2(2, N) = arrAll(I, 2) N = N + 1 End If Next End With With Add .lb_all.List = arrL1 .lb_add.List = Application.Transpose(arrL2) End With End Sub