Creating New Excel Sheets for Each Row in a Worksheet - excel

Question

I am working on an Excel workbook in which I would like the workbook to create a new sheet for each new row of data. The code below does do this, but the problem is that Excel uses the text in the first column of each row as the name for the new sheets. I would like to change this and make another column the source for the new sheet name. Please advise on which line(s) I would need to change to accomplish this. Thanks for the help!
Sub Parse_data()
Dim xRCount As Long
Dim xSht As Worksheet, xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = ActiveSheet
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
'xTitle = "C1:C1"
'xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
On Error Resume Next
Call xCol.Add(xSht.Cells(I, 1), xSht.Cells(I, 1))
Next
On Error Resume Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
xNSht.Name = CStr(xCol.Item(I))
Else
xNSht.Move , Sheets(Sheets.Count)
End If
xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub

Answer 1

Try this. I added another collection, yCol, which contains data from a different column but which uses the same key as xCol.
Sub Parse_data()
Dim xRCount As Long
Dim xSht As Worksheet, xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim yCol as New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = ActiveSheet
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
'xTitle = "C1:C1"
'xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
On Error Resume Next
Call xCol.Add(xSht.Cells(I, 1), xSht.Cells(I, 1))
Call yCol.Add(xSht.Cells(I, 2), xSht.Cells(I, 1)) 'change 2 to whatever column you want as the name
Next
On Error Resume Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
xNSht.Name = CStr(yCol.Item(I)) 'here's my magic switcheroo
Else
xNSht.Move , Sheets(Sheets.Count)
End If
xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub