在两个数组中查找不匹配并将不匹配添加到列中的最后一个位置

Question

我正在尝试通过在 excel VBA 中使用两个数组来查找多个列中的不匹配项

因此，代码在“Sammanställning”工作表中的 A 列（varr 数组）中使用，作为 Facit 上的一种，用于另一个数组 arr（来自其他工作表的列 k）来查找不匹配项，然后将不匹配项添加到最后“Sammanställning”表中的 A 列。

现在解决问题：

它有效，但只是一种。它进行匹配，找到不匹配的将其添加到正确位置的末尾。 但是在第一张纸之后，如果它添加了不匹配的内容，它不会更新 varr 数组。 我尝试使用下面的 3 种变体更新数组，但没有奏效。我收到“超出索引”错误。

ReDim Preserve varr(LBound(varr) To (UBound(varr) + 1)) As Variant
ReDim Preserve varr(LBound(varr) To (UBound(varr) + 1))
ReDim Preserve varr(UBound(varr) + 1)

第一部分是为了避免看错表格，为此我使用 GlobalSheetName。

 Sub KollaFlyttaData()

 Dim ws As Worksheet
 Dim ShName As String
 Dim char As Variant
 Dim blnChar As Boolean
 Dim Sistaraden As Variant
 Dim varr As Variant
 varr = Sheets("Sammanställning").Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value

   For Each ws In ActiveWorkbook.Worksheets
        For Each char In Split(GlobalSheetName, ",")
            If ws.Name = char Then
              blnChar = True
              Exit For
            Else
              blnChar = False
            End If
        Next
        If Not blnChar = True Then
                ws.Activate
                    Dim arr As Variant
                    arr = Range("K3:K" & Cells(Rows.Count, "K").End(xlUp).Row).Value
                    Dim x As Variant, y As Variant, match As Boolean
                    For Each x In arr
                        match = False
                        For Each y In varr
                            If x = y Then match = True
                        Next y
                            If Not match Then
                                Sistaraden = Sheets("Sammanställning").Cells(Rows.Count, "A").End(xlUp).Row + 1
                                Sheets("Sammanställning").Range("A" & Sistaraden).Value = x
                                ReDim Preserve varr(LBound(varr) To (UBound(varr) + 1)) As Variant
                            End If
                            Next x
                End If
      Next
    End Sub

如何更新 varr，以便添加所有不匹配项并将不匹配项添加到“Sammanställning”工作表中 A 列的最后一个非空单元格之后。

Answer 1

你能用字典代替吗？您可以将其与按钮推送或工作表事件（可能是第一个更容易）联系起来，以便继续更新。

我暂时避免使用您的代码来获取正确的表格并简单地演示字典部分：

Option Explicit

Sub KollaFlyttaData()

    Dim ws As Worksheet
    Dim varr()
    With Sheets("Sammanställning")
        varr = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
    End With

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim currValue As Long

    For currValue = LBound(varr, 1) To UBound(varr, 1)
        If Not dict.exists(varr(currValue, 1)) And Len(varr(currValue, 1)) > 0 Then
            dict.Add varr(currValue, 1), varr(currValue, 1)
        End If
    Next currValue

    For Each ws In ActiveWorkbook.Worksheets

        With ws

            Dim arr()
            arr = .Range("K3:K" & .Cells(Rows.Count, "K").End(xlUp).Row).Value

            For currValue = LBound(arr, 1) To UBound(arr, 1)

             If Not dict.exists(arr(currValue, 1)) And Len(arr(currValue, 1)) > 0 Then
                dict.Add arr(currValue, 1), arr(currValue, 1)
             End If

            Next currValue

        End With

    Next ws

    ActiveWorkbook.Sheets("Sammanställning").Range("A1").Resize(dict.Count, 1) = Application.WorksheetFunction.Transpose(dict.keys)

End Sub