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

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