CODEWITHSUNDEEP
excelvba
Matthew Croft
Matthew Croft

Reputation: 71

Creating New Excel Sheets for Each Row in a Worksheet

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

Upvotes: 0

Views: 3980

Answers (1)

elliot svensson
elliot svensson

Reputation: 603

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

Upvotes: 1

Related Questions