为工作表中的每一行创建新的Excel工作表

我正在制作Excel工作簿，希望工作簿为每一行数据创建一个新的工作表。下面的代码可以做到这一点，但问题是Excel使用每行第一列中的文本作为新工作表的名称。我想更改此项，并使另一列成为新工作表名称的源。请告知我需要更改哪些线路才能完成此任务。谢谢你的帮助

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

---

试试这个。我添加了另一个集合yCol，它包含来自不同列的数据，但使用与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

---

xNSht.Name=CStrxCol.ItemIYou想要将Call xCol.AddxSht.CellsI，1，xSht.CellsI，1中的1更改为您想要的列引用。抱歉，我刚刚更新了此建议。。。我之前在那里留下了一个打字错误，我的新收藏也是xCol，而不是我想添加的yCol。