Similar Grouping in vba - vba

Question

I have two for loops in vba that are iterating over column b and checking to see if the first word in the current cell is the same as the first word in any other cell and if so copying them into another column, therefore grouping similar items. But, when I go to copy and paste the matches it finds, it only copy and pastes the matches, not the original cells that it is comparing against. I would like to have the matches and the original cells as well in the grouping but I am unsure where to modify my code so it will do so. I am rather new to vba so any help would be greatly appreciated.
Sub FuzzySearch()
Dim WrdArray1() As String, WrdArray2() As String, i As Long, Count As Long, Rng1 As Range
Dim WS As Worksheet, positionx As Long, positiony As Long
Dim rng2 As Range
Set WS = ThisWorkbook.ActiveSheet
With WS
Set Rng1 = .Range("B2:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
End With
For i = 1 To Rng1.Rows.Count
With Columns("B")
.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas).Activate
End With
position = 1
For j = 1 To Rng1.Rows.Count
WrdArray1 = Split(ActiveCell.Value, " ")
ActiveCell.Offset(1).Activate
WrdArray2 = Split(ActiveCell.Value, " ")
If UBound(WrdArray2) < 0 Then
End
End If
If WrdArray1(0) = WrdArray2(0) Then
ActiveCell.Copy Destination:=ActiveSheet.Range("C" & position)
position = position + 1
Count = Count + 1
End If
Next j
Next i
End Sub

Answer 1

Given that you are using a mixture of arrays and Ranges it would probably be easier and less confusing to populate one of the arrays with the final output (including the comparator) within a loop and then transfer the array to the worksheet in a single command.
However, perhaps consider the following approach which lets Excel do all the 'heavy lifting'. It's the same number of code lines but I have annotated it for your information. This illustrates the filling of an array in a loop and transferring it to a Range. Change the various variables to suit your situation.
Sub grpAndCount()
Dim ws As Worksheet
Dim strow As Long, endrow As Long, stcol As Long
Dim coloffset As Long, r As Long
Dim newstr As String
Dim drng As Range
Dim strArr() As String
'Data start r/c
strow = 6 'Row 6
stcol = 2 'Col B
'Offset no of Cols from Data to place results
coloffset = 2
Set ws = Sheets("Sheet1")
With ws
'find last data row
endrow = Cells(Rows.Count, stcol).End(xlUp).Row
'for each data row
For r = strow To endrow
'get first word
newstr = Left(.Cells(r, stcol), InStr(.Cells(r, stcol), " ")-1)
'put string into array
ReDim Preserve strArr(r - strow)
strArr(r - strow) = newstr
Next r
'put array to worksheet
Set drng = .Range(.Cells(strow, stcol + coloffset), .Cells(endrow, stcol + coloffset))
drng = Application.Transpose(strArr)
'sort newly copied range
drng.Sort Key1:=.Cells(strow, stcol + coloffset), Order1:=xlAscending, Header:=xlNo
'provide a header row for SubTotal
.Cells(strow - 1, stcol + coloffset) = "Header"
'resize range to include header
drng.Offset(-1, 0).Resize(drng.Rows.Count + 1, 1).Select
'apply Excel SubTotal function
Application.DisplayAlerts = False
Selection.Subtotal GroupBy:=1, Function:=xlCount, Totallist:=Array(1)
Application.DisplayAlerts = True
'remove 'Header' legend
.Cells(strow - 1, stcol + coloffset) = ""
End With
End Sub