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

Question

我正在尝试编写一个循环，将 A 列中的所有值与 MyArray 中的所有值进行比较。如果单元格值与数组中的某些值相同，我想将该单元格复制到另一个相应的工作表(所有工作表都被命名为数组中的元素)。

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 Integer

    FinalRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

With ws

'Part that creates my Array without duplicates


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

End With

'I copy column A from another sheet in order to restore values erased with .removeduplicates
'I've tried to remove duplicates from the Array itself but I kept getting errors so I've decided to go with this workaround
ws2.Range("A2", ws2.Range("A2").End(xlDown)).Copy Destination:=ws.Cells(2, 1)


For Each element In MyArray
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = element
Next element

' Below part works well but only for the number of rows equal to number of elements in the array ~15

For i = 2 To FinalRow
    For Each element In MyArray

        If element = ws.Cells(i, 1).Value Then

        ws.Cells(i, 1).Copy Destination:=wb.Worksheets(element).Cells(i, 1)

        End If

  Next element

Next i

ws.Activate

End Sub

一切似乎都工作正常，但仅限于行数等于数组中元素数的情况。我认为循环中的逻辑有问题，但我看不出什么问题。

Answer 1

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

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