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

Вход

Регистрация

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

 

= Мир MS Excel/Занести в ListBox разницу двух таблиц в одной книге - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Занести в ListBox разницу двух таблиц в одной книге (Макросы/Sub)
Занести в ListBox разницу двух таблиц в одной книге
sokodi Дата: Среда, 27.03.2019, 07:56 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Не нашел моего примера, есть только сравнение таблиц при одинаковом значении.

На форме имеется два листбокса. На верхнем (Л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]
К сообщению приложен файл: 1363898.xlsm(29.3 Kb)


Сообщение отредактировал sokodi - Среда, 27.03.2019, 07:57
 
Ответить
СообщениеНе нашел моего примера, есть только сравнение таблиц при одинаковом значении.

На форме имеется два листбокса. На верхнем (Л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]

Автор - sokodi
Дата добавления - 27.03.2019 в 07:56
sokodi Дата: Среда, 27.03.2019, 07:58 | Сообщение № 2
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Как должно получиться
 
Ответить
СообщениеКак должно получиться

Автор - sokodi
Дата добавления - 27.03.2019 в 07:58
sokodi Дата: Среда, 27.03.2019, 08:57 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Всем спасибо.
[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
[/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
[/vba]

Автор - sokodi
Дата добавления - 27.03.2019 в 08:57
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Занести в ListBox разницу двух таблиц в одной книге (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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