Извлечение сходных данных из нескольких листов из исходных данных

Question

Вот что я пытаюсь выполнить sh: у меня есть список на листе "dat1"; это исходные данные (столбец 1). У меня есть листы "min1" и "min2", которые состоят из данных, которые похожи на данные n Столбец 1 листа "dat1", хотя оба этих списка короче исходных данных.

Чтобы сделать его более наглядным:

Data "dat1"
a
b
c
d
e
f
g

Data "min1"
a
d
c

Data "min2"
e
g

Result = dat1 - min1 - min2 = "EndResult"
b
f

Это то, что я ожидал, сработает:

Sub extract()

    Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet, sht4 As Worksheet
    Dim lr1 As Long, lr2 As Long, lr3 As Long
    Dim chk1 As Variant, chk2 As Variant, chk3 As Variant
    Dim i As Long, j As Long, k As Long

    Set sht1 = ThisWorkbook.Worksheets("dat1") 'original data range
    Set sht2 = ThisWorkbook.Worksheets("min1") 'partial data resembling dat1
    Set sht3 = ThisWorkbook.Worksheets("min2") 'partial data resembling dat1
    Set sht4 = ThisWorkbook.Worksheets("EndResult") 'orginal data minus resembling data from min1 and min2

    lr1 = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row
    lr2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
    lr3 = sht3.Cells(sht3.Rows.Count, "A").End(xlUp).Row


    chk1 = sht1.Range("A1:B" & lr1).Value
    chk2 = sht2.Range("A1:A" & lr2).Value
    chk3 = sht3.Range("A1:A" & lr3).Value

    For i = LBound(chk1) To UBound(chk1)
    For j = LBound(chk2) To UBound(chk2)
    For k = LBound(chk3) To UBound(chk3)

        If chk1(i, 1) <> chk2(j, 1) And chk1(i, 1) <> chk3(k, 1) Then
            If IsEmpty(sht4.[A1].Value) Then
                sht4.[A1].Value = chk1(i, 1)
            Else: sht4.Cells(sht4.Rows.Count, "A").End(xlUp).Offset(1).Value = chk1(i, 1)
            End If
        End If

    Next
    Next
    Next

End Sub

Это не работает, но я не знаю почему. Кто может объяснить / помочь мне?

Answer 1

Вы можете использовать функцию фильтра VBA. Я читаю данные в массивы для более быстрой обработки:

Option Explicit
Sub extract()
    Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet, sht4 As Worksheet
    Dim vdat1 As Variant, vmin1 As Variant, vmin2 As Variant, vRes As Variant
    Dim V As Variant

With ThisWorkbook
    Set sht1 = .Worksheets("dat1")
    Set sht2 = .Worksheets("min1")
    Set sht3 = .Worksheets("min2")
    Set sht4 = .Worksheets("EndResult")
End With

With sht1
    vdat1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With sht2
    vmin1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With sht3
    vmin2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'make vdat a 1D array
vdat1 = WorksheetFunction.Transpose(vdat1)

'filter out the mins
For Each V In vmin1
    vdat1 = Filter(vdat1, V, False, vbTextCompare)
Next V

For Each V In vmin2
    vdat1 = Filter(vdat1, V, False, vbTextCompare)
Next V

'make vdat a 2D array
vdat1 = WorksheetFunction.Transpose(vdat1)

'write the results
Dim rRes As Range
Set rRes = sht4.Cells(1, 1).Resize(rowsize:=UBound(vdat1))

With rRes
    .EntireColumn.Clear
    .Value = vdat1
    .EntireColumn.AutoFit
End With

End Sub

Answer 2

вы можете использовать AutoFilter()

См. Мой код, где я:

• умело изменил ваш код (см. '<---... комментарии) перед вложенным For петли

• замещенные вложенные For петли с двумя AutoFilter с подряд

Вот код:

Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet, sht4 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long
Dim chk2 As Variant, chk3 As Variant
Dim chk1Rng As Range '<--
Dim i As Long, j As Long, k As Long

Set sht1 = ThisWorkbook.Worksheets("dat1") 'original data range
Set sht2 = ThisWorkbook.Worksheets("min1") 'partial data resembling dat1
Set sht3 = ThisWorkbook.Worksheets("min2") 'partial data resembling dat1
Set sht4 = ThisWorkbook.Worksheets("EndResult") 'orginal data minus resembling data from min1 and min2

lr1 = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row
lr2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
lr3 = sht3.Cells(sht3.Rows.Count, "A").End(xlUp).Row


Set chk1Rng = sht1.Range("A1:B" & lr1) ' <-- set data range
chk2 = sht2.Range("A1:A" & lr2).Value
chk3 = sht3.Range("A1:A" & lr3).Value


'--------------
With chk1Rng ' reference data range
    .Rows(1).Insert ' insert helper row for dummy header
    With .Offset(-1).Resize(.Rows.Count + 1) ' enlarge data rage to embrace newly inserted row
        .Cells(1, 1).Value = "h1" ' filled newly inserted rows with dummy header
        .AutoFilter field:=1, Criteria1:=Application.Transpose(chk2), Operator:=xlFilterValues ' filter referenced range on its 1st column with 'min1' values
        .AutoFilter field:=1, Criteria1:=Application.Transpose(chk3), Operator:=xlFilterValues ' filter referenced range on its 1st column with 'min2' values
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy sht4.Cells(1, 1) ' copy unfiltered cells to 'sht4'
        .Parent.AutoFilterMode = False ' remove autofilter
        .Rows(1).EntireRow.Delete xlUp ' delete "helper" row
    End With
End With
'--------------