Split Data into Multiple Sheets with VBA-CodePudding

The goal is to split my Raw Data into new sheets based on unique values found in 1 column. I found the following VBA code that does what I need however the customer I will be utilizing this for has a locked excel "workbook" that I cannot change the order of the Raw Data columns on. With that being the case, this VBA code utilizes column A however my target column is C.

The new sheets also seem to name after whatever the target data is but I would like to know how to change this so I can specify a cell for the sheet name.

Question 1: What part of this code can I change to make the target column C instead of A. Question 2: How can I change the .name portion to be the value in AF2 on each sheet?

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

End Sub

EDIT TO INCLUDE CUSTOMER TEMPLATE I AM REQUIRED TO USE https://www.dropbox.com/scl/fi/qb9484lmdyeo1aieqlb4m/HDTemplate.xlsx?dl=0&rlkey=6dlt1nlo8lehmnpl8cdipwbkp

CodePudding user response：

UPDATED I'm pretty sure my first answer should work in a normal setting which makes me think there's something else going on. However, if resorting the columns is all you need, consider this macro which just makes a new worksheet. For the record this is pretty inefficient to begin with. You could use pivot tables the Filter function or probably lots of other options to do whatever you need. But anyway....

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

First Answer See below code changes and comments to your questions.

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