Splitting Excel column into different tabs - vba

Question

I am trying to split data from an Excel column in to different tabs for each unique value. For example, I'd like a tab for each unique value in the Concat field that lists only the records for that specific person.
Currently using this code, which splits the tabs out correctly, but each tab has all of the worksheet's data, not just the individualized data.
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 5
Set ws = Sheets("qReconcilers")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:N1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
How would I get those tabs to only display the data pertaining to that particular person?

Answer 1

Something like this should be ok for a beginning:
Public Sub TestMe()
Dim defaultColumn As Long
defaultColumn = 5 'column E
Dim wks As Worksheet
Dim sourcelastRow As Long
Set wks = Worksheets(1) 'the main worksheet
sourcelastRow = lastRow(wks.Name)
Dim cnt As Long
Dim checkCell As Range
For cnt = 2 To sourcelastRow
Set checkCell = wks.Cells(cnt, defaultColumn)
If WorksheetFunction.IsErr(Evaluate("'" & Trim(checkCell) & "'!A1")) Then
Dim newSheet As Worksheet
Set newSheet = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
newSheet.Name = Trim(checkCell.Value2)
End If
Dim targetLastRow As Long
targetLastRow = lastRow(checkCell.Value2) + 1
Worksheets(checkCell.Value2).Rows(targetLastRow).Value2 = wks.Rows(cnt).Value2
Next cnt
End Sub
Public Function lastRow(Optional strSheet As String, _
Optional column_to_check As Long = 1) As Long
Dim shSheet As Worksheet
If strSheet = vbNullString Then
Set shSheet = ActiveSheet
Else
Set shSheet = Worksheets(strSheet)
End If
lastRow = shSheet.Cells(shSheet.Rows.Count, column_to_check).End(xlUp).Row
End Function
What the code does:
loops through every cell in column number 5 of the first worksheet;
checks whether there is a worksheet with the name of this column";
WorksheetFunction.IsErr(Evaluate("'" & Trim(checkCell) & "'!A1"))
if there is no such worksheet - it creates it;
then finds the worksheet with this column and at the row after the last used row of the worksheet it writes the values of the corresponding row;