Loop comparing cells with array values vba - 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

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 2

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