Как найти различия в столбце А в 4 разных листах

Question

У меня есть столбец K на листах «фильтра», который необходимо сравнить со столбцом A на листах «Active_Buy», «Active_Others» и «Active_Make» соответственно.

Сначала его нужно сравнить с листами active_buy.если есть значение, которое в столбце K (лист фильтра), но не в столбце A (лист active_Buy), необходимо сохранить это значение и сравнить его со столбцом A (листы active_others).Если также не совпадает, его необходимо сравнить со столбцом A (листы Active_Make).

Таким образом, если совпадений нет, то значение необходимо вставить в имя нового листа (номер детали не соответствует).

Я уже ищу везде, но могу найти только код, который может сравнивать только 2 листа, но не более того.

«Ниже приведен код, который я нашел, но сравнил только две таблицы» - концепция, такая же, как эта, но должна содержать несоответствующее значение и сравнивать со следующей таблицей и т. Д.

Sub compare()
    Sheets(3).Activate  'Go to sheet 3
    Cells.Clear         'and clear all previous results

    Range("a1").Select  'set cursor at the top

    Sheets(1).Activate  'go to sheet 1
    Range("a1").Select  'begin at the top

    Dim search_for As String   'temp variable to hold what we need to look for
    Dim cnt As Integer         'optional counter to find out how many rows we found

    Do While ActiveCell.Value <> ""   'repeat the follwoing loop until it reaches a blank row

        search_for = ActiveCell.Offset(0, 1).Value   'get a hold of the value in column B

        Sheets(2).Activate  'go to sheet(2)

        On Error Resume Next   'incase what we search for is not found, no errors will stop the macro

        Range("b:b").Find(search_for).Select  'find the value in column B of sheet 2

        If Err <> 0 Then   'If the value was not found, Err will not be zero

            On Error GoTo 0  'clearing the error code

            Sheets(1).Activate   'go back to sheet 1

            r = ActiveCell.Row   'get a hold of current row index

            Range(r & ":" & r).Select  'select the whole row

            cnt = cnt + 1   'increment the counter

            Selection.Copy  'copy current selection

            Sheets(3).Activate  'go to sheet 3

            ActiveCell.PasteSpecial xlPasteAll  'Past the entire row to sheet 3

            ActiveCell.Offset(1, 0).Select  'go down one row to prepare for next row.


        End If
        Sheets(1).Activate   'return to sheet 1
        ActiveCell.Offset(1, 0).Select   'go to the next row

    Loop   'repeat

    Sheets(3).Activate    'go to sheet 3 to examine findings

    MsgBox "I have found " & cnt & " rows that did not exist in sheet 2"

End Sub

Answer 1

Вот саб, который принимает 2 параметра;

Ячейка, в которой есть значение для поиска, и число, указывающее лист для поиска.

Когда подпрограмма не находит значение ни на одном из листов, она добавляетновый лист «Несоответствующий номер детали», если он не существует, и добавляет значение, которое не найдено в столбце A на этом листе:

Sub searchSheet(ByVal searchFor As Range, sheetNum As Integer)

    Dim sheetsArr As Variant
    sheetsArr = Array("Active_Buy", "Active_Others", "Active_Make", "Unmatched Part No") 'You can change the names of your sheets here

    If sheetNum = 3 Then   'When we reach the last sheet in our array, then we haven't find a match in neither of the previous sheets

        Dim ws As Worksheet, wsExist As Boolean, lastRow As Integer
        wsExist = False
        'Check if the sheet "Unmatched Part No" exists
        For Each ws In Worksheets
            If ws.Name = sheetsArr(3) Then
                wsExist = True
                Exit For
            End If
        Next ws

        'If the sheet "Unmatched Part No" doesn't exist add one with this name
        If Not (wsExist) Then ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = sheetsArr(3)
        lastRow = ThisWorkbook.Sheets(sheetsArr(3)).Cells(Rows.Count, "A").End(xlUp).Row 'last used row in column A in the unmatched sheet
        ThisWorkbook.Sheets(sheetsArr(3)).Range("A" & lastRow + 1).Value2 = searchFor.Value2 'append the unfound value in column A
        'MsgBox "New value" & searchFor.Value2 & "appended to 'Unmatched Part No' A" & lastRow + 1
        Exit Sub

    End If

    Dim search  'Search should be of a variant type to accept errors given by the match function
    search = Application.Match(searchFor.Value2, ThisWorkbook.Sheets(sheetsArr(sheetNum)).Range("A:A"), 0)
    If IsError(search) Then searchSheet searchFor, sheetNum + 1  'When match doesn't find the searchFor value, Search is an #N/A error, then search in the next sheet

End Sub

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

Sub lookInSheets()

    Dim lastRw As Integer, ctrlCol As Range
    lastRw = ThisWorkbook.Sheets("filter").Cells(Rows.Count, "K").End(xlUp).Row   'To abbreviate the search to just the filled cells in column K
    Set ctrlCol = ThisWorkbook.Sheets("filter").Range("K1:K" & lastRw)

    For Each ctrlCell In ctrlCol
        searchSheet ctrlCell, 0
    Next ctrlCell

End Sub

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

Answer 2

Я бы использовал цикл «Для каждого», чтобы просмотреть значения на листе «Фильтр», установить диапазоны на каждом из остальных листов, а затем проверить каждый из диапазонов.Я проверил этот код, и он, кажется, делает свое дело.Я прокомментировал, чтобы вы могли видеть, что происходит в каждой строке.

(Вам нужно будет настроить имена листов, чтобы они соответствовали вашим собственным, и настроить параметры приложения, чтобы все работало быстрее, если у вас естьмного данных.)

Sub compareColumns()

Dim lastRow1, lastRowAB, lastRowAO, lastRowAM, lastRowUMPN As Long
Dim rng1, rngAB, rngAO, rngAM As Range
Dim cell As Range
Dim found As Range

' Define our last rows for each sheet
lastRow1 = ThisWorkbook.Worksheets("FilterSheet").Range("K" & Rows.Count).End(xlUp).Row
lastRowAB = ThisWorkbook.Worksheets("ActiveBuy").Range("A" & Rows.Count).End(xlUp).Row
lastRowAO = ThisWorkbook.Worksheets("ActiveOthers").Range("A" & Rows.Count).End(xlUp).Row
lastRowAM = ThisWorkbook.Worksheets("ActiveMake").Range("A" & Rows.Count).End(xlUp).Row
lastRowUMPN = ThisWorkbook.Worksheets("UnmatchedPartNo").Range("A" & Rows.Count).End(xlUp).Row

' Set the ranges that we'll loop through
Set rng1 = ThisWorkbook.Worksheets("FilterSheet").Range("K1:K" & lastRow1)
Set rngAB = ThisWorkbook.Worksheets("ActiveBuy").Range("A1:A" & lastRowAB)
Set rngAO = ThisWorkbook.Worksheets("ActiveOthers").Range("A1:A" & lastRowAO)
Set rngAM = ThisWorkbook.Worksheets("ActiveMake").Range("A1:A" & lastRowAM)

' Loop through each cell in the filtered sheet
For Each cell In rng1
    ' Try to find the value in ActiveBuy sheet
    Set found = rngAB.Find(cell.Value)
    ' If not found, try the next sheet
    If found Is Nothing Then
        Set found = rngAO.Find(cell.Value)
        ' If not found, try the next sheet
        If found Is Nothing Then
            Set found = rngAM.Find(cell.Value)
            ' If still not found, copy to the value to the 'Unmatched Parts' sheet
            If found Is Nothing Then
                ThisWorkbook.Worksheets("UnmatchedPartNo").Range("A" & lastRowUMPN + 1).Value = cell.Value
                MsgBox "I have found a value " & cell.Value & " that did not exist in any sheets."
            End If
        End If
    End If
' Reset 'found' to equal nothing for the next loop
Set found = Nothing
Next

End Sub