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

Question

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

arraysvbaexcel

3

我正在尝试使用Excel VBA中的两个数组，在多个列中查找不匹配项。

因此，代码在“Sammanställning”工作表中使用列A（varr数组）作为其他工作表中列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 列最后一个非空单元格之后。

- Mirkaminer

1

当您执行 varr = Sheets("Sammanställning").Range("A1:A" ... 时，它是从区域中获取 Values 的快照。如果您稍后更新该区域，则需要再次执行 varr = ...（而不是 redim varr ...）。 - chris neilsen

我执行了 varr=... 但只能将已经存在于列表中的数据添加更多新单元格。 - Mirkaminer

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- QHarr · 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