使用 VBA 将数据拆分为多个工作表

Question

目标是根据 1 列中的唯一值将我的原始数据拆分为新工作表。我发现以下 VBA 代码可以满足我的需要，但是我将使用它的客户有一个锁定的 excel“工作簿”，我无法更改原始数据列的顺序。在这种情况下，此 VBA 代码使用列 A，但我的目标列是 C。

新工作表似乎也以目标数据命名，但我想知道如何更改它，以便为工作表名称指定一个单元格。

问题 1：我可以更改此代码的哪一部分以使目标列 C 而不是 A。 问题 2：如何将 .name 部分更改为每张纸上 AF2 中的值？

Sub parse_data()
Dim xRCount As Long
Dim xSht As Worksheet
Dim 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
On Error Resume Next
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A1:AD1"
xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
    Call xCol.Add(xSht.Cells(I, 1).Text, xSht.Cells(I, 1).Text)
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

结束子

编辑以包含我需要使用的客户模板 https://www.dropbox.com/scl/fi/qb9484lmdyeo1aieqlb4m/HDTemplate.xlsx?dl=0&rlkey=6dlt1nlo8lehmnpl8cdipwbkp

Answer 1

更新 我很确定我的第一个答案应该在正常环境下工作，这让我觉得还有其他事情发生。但是，如果您只需要使用列，请考虑这个宏，它只是创建一个新工作表。为了记录，这开始时效率很低。您可以使用数据透视表、过滤器功能或许多其他选项来做任何您需要的事情。但无论如何....

Sub fixYourData()

Dim tempWS As Worksheet, pullWs As Worksheet, rNum As Long
    pullWs = ActiveSheet
    rNum = pullWs.Cells(Rows.Count, 1).End(xlUp).Row
    Set tempWS = Worksheets.Add
With tempWS
    .Range("A1:A" & rNum).Value = xSht.Range("C1:C" & rNum).Value
    .Range("B1:B" & rNum).Value = xSht.Range("B1:B" & rNum).Value
    .Range("C1:C" & rNum).Value = xSht.Range("A1:A" & rNum).Value
    .Range("D1:AD" & rNum).Value = xSht.Range("D1:AD" & rNum).Value
End With

Call parse_data '<--- will run your original macro

End Sub

第一个答案 请参阅下面的代码更改和您的问题的 cmets。

Sub parse_data()





Dim xRCount As Long
Dim xSht As Worksheet
Dim 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
On Error Resume Next
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A1:AD1"
xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
    Call xCol.Add(xSht.Cells(I, 3).Text, xSht.Cells(I, 3).Text) '<---Q1 here
Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
    Call xSht.Range(xTitle).AutoFilter(3, CStr(xCol.Item(I))) '<---Q1 here
    Set xNSht = Nothing
    Set xNSht = Worksheets(CStr(xCol.Item(I)))
    If xNSht Is Nothing Then
        Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
        
    Else
        xNSht.Move , Sheets(Sheets.Count)
    End If
    xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
    xNSht.Columns.AutoFit
    xNSht.Name = xNSht.Range("AF2").Value ' <-- Q2 here
    
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub