Loop comparing cells with array values vba

Question

I am trying to write a loop comparing all the values from the column A with all the values from MyArray. If cell value is the same as some value from the array, I would like to copy that cell to another corresponding sheet (All sheets are named as elements in the array).

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

Everything seems to work fine but only for the number of rows equal to number of elements in the array. I think that there is something wrong with the logic in the loop but I can't see what.

Answer 1

Also with a dictionary

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

Answer 2

Maybe this? Your loop runs to FinalRow but you subsequently change the values in column A so presumably is not up to date. You can use Match to avoid the inner loop.

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 3

I'd use Dictionary object

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