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

Answer 2

我使用Dictionary对象

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

Answer 3

还有字典

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

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

3 个答案: