循环比较单元格与数组值vba

我试图编写一个循环，将a列中的所有值与MyArray中的所有值进行比较。如果单元格值与数组中的某个值相同，我希望将该单元格复制到另一个对应的工作表（所有工作表都被命名为数组中的元素）

一切似乎都很好，但只适用于行数等于数组中元素数的情况。

---

我认为循环中的逻辑有问题，但我看不出是什么。

可能是这个？循环运行到FinalRow，但随后更改了列A中的值，因此可能不是最新的。可以使用“匹配”来避免内部循环

Sub sheets()

Dim MyArray As Variant
Dim element As Variant
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets(1)
Dim ws2 As Worksheet
Set ws2 = wb.Worksheets("Sheet2")
Dim i As Long
Dim r As Range
Dim v As Variant

With ws
    .Range("A2", .Range("A2").End(xlDown)).RemoveDuplicates Columns:=Array(1)
    MyArray = .Range("A2", .Range("A2").End(xlDown))
End With

ws2.Range("A2", ws2.Range("A2").End(xlDown)).Copy Destination:=ws.Cells(2, 1)

For Each element In MyArray
    wb.sheets.Add(After:=wb.sheets(wb.sheets.Count)).Name = element
Next element

For Each r In ws.Range("A2", ws.Range("A2").End(xlDown))
    v = Application.Match(r, MyArray, 0)
    If IsNumeric(v) Then
        r.Copy Destination:=wb.Worksheets(CStr(MyArray(v,1))).Cells(r.Row, 1)
    End If
Next r

ws.Activate

End Sub

---

我会使用

字典

对象

Sub sheetss()
    Dim cell As Range
    Dim dict1 As Object, dict2 As Object

    With ThisWorkbook ' reference wanted workbook
        Set dict1 = CreateObject("Scripting.Dictionary")
        With .Worksheets(1) ' reference referenced workbook relevant worksheet
            For Each cell In .Range("A2", .Range("A2").End(xlDown)) ' loop through referenced worksheet column A cells from row 2 down to last not empty one
                dict1(cell.Value) = 1 'store unique values from looped cells into dictionary keys
            Next
        End With

        Set dict2 = CreateObject("Scripting.Dictionary")
        With .Worksheets("Sheet2") ' reference referenced workbook relevant worksheet
            For Each cell In .Range("A2", .Range("A2").End(xlDown)) ' loop through referenced worksheet column A cells from row 2 down to last not empty one
                dict2(cell.Value) = dict1.exists(cell.Value) 'store unique values from looped cells into dictionary keys and its presence in first worksheet column A cells into corresponding item
            Next
        End With

        Dim key As Variant
        For Each key In dict2.keys ' loop through 2nd worksheet column A unique values
            If dict2(key) Then ' if it was in 1st worksheet column A cells also
                .sheets.Add(After:=ThisWorkbook.sheets(ThisWorkbook.sheets.Count)).Name = key ' create corresponding worksheet
                .sheets(key).Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = key ' copy its value into cell B1 of newly created worksheet
            End If
        Next
    End With
End Sub

还有一本字典

Option Explicit

Public Sub WriteToSheets()
    Application.ScreenUpdating = False
    Dim MyArray As Variant, wb As Workbook, ws As Worksheet, ws2 As Worksheet, i As Long, dict As Object, rng As Range
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets(1)
    Set ws2 = wb.Worksheets("Sheet2")
    Set dict = CreateObject("Scripting.Dictionary")

    With ws
        MyArray = Intersect(.Columns(1), .UsedRange)
        For i = LBound(MyArray, 1) To UBound(MyArray, 1)
            If Not dict.exists(MyArray(i, 1)) Then
                dict.Add MyArray(i, 1), 1
                On Error Resume Next 'in case already exists
                wb.sheets.Add(After:=wb.sheets(wb.sheets.Count)).Name = MyArray(i, 1)
                On Error GoTo 0
            End If
        Next i
    End With
    With ws2
        For Each rng In Intersect(.Columns(1), .UsedRange)
            If dict.exists(rng.Value) Then
                rng.Copy wb.Worksheets(rng.Value).Range("A" & GetNextRow(wb.Worksheets(rng.Value), 1))
            End If
        Next rng
    End With
    Application.ScreenUpdating = True
End Sub

Public Function GetNextRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetNextRow = IIf(.Cells(.Rows.Count, columnNumber).End(xlUp).Row = 1, 1, .Cells(.Rows.Count, columnNumber).End(xlUp).Row + 1)
    End With
End Function

---

非常感谢。我必须分析这段代码，因为我没有使用字典的经验，但我肯定会在未来的数据库中使用它。我没有使用词典的经验，但你的评论对我理解词典的工作原理非常有帮助。让我知道你的最终选择是什么

Option Explicit

Public Sub WriteToSheets()
    Application.ScreenUpdating = False
    Dim MyArray As Variant, wb As Workbook, ws As Worksheet, ws2 As Worksheet, i As Long, dict As Object, rng As Range
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets(1)
    Set ws2 = wb.Worksheets("Sheet2")
    Set dict = CreateObject("Scripting.Dictionary")

    With ws
        MyArray = Intersect(.Columns(1), .UsedRange)
        For i = LBound(MyArray, 1) To UBound(MyArray, 1)
            If Not dict.exists(MyArray(i, 1)) Then
                dict.Add MyArray(i, 1), 1
                On Error Resume Next 'in case already exists
                wb.sheets.Add(After:=wb.sheets(wb.sheets.Count)).Name = MyArray(i, 1)
                On Error GoTo 0
            End If
        Next i
    End With
    With ws2
        For Each rng In Intersect(.Columns(1), .UsedRange)
            If dict.exists(rng.Value) Then
                rng.Copy wb.Worksheets(rng.Value).Range("A" & GetNextRow(wb.Worksheets(rng.Value), 1))
            End If
        Next rng
    End With
    Application.ScreenUpdating = True
End Sub

Public Function GetNextRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetNextRow = IIf(.Cells(.Rows.Count, columnNumber).End(xlUp).Row = 1, 1, .Cells(.Rows.Count, columnNumber).End(xlUp).Row + 1)
    End With
End Function