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

Question

我正在处理一个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

Answer 1

试试这个。我添加了另一个集合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