Parsing A Excel Worksheet using VBA

[Andrea Schanz]

I have a worksheet with codes in column A. I want to create new sheets based on the codes in column A, such that each code is on a new sheet. I found the following excel vba code but I cannot figure out how to get it to place rows 1 and 2 on each new worksheet.

Sub parse_data()

'
'Create new sheet for each row based on column A
'
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
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = ("A1:AN2")

xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 3 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
'A1 designates what the cell to place the data
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

 

[dmt32]

Hi,
see if this alternative code will do what you want:

Sub FilterData()
    'DMT32
    Dim ws1Master As Worksheet, wsParse As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range
    Dim rowcount As Long
    Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
    Dim SheetName As String, msg As String




    'master sheet
    Set ws1Master = ActiveSheet


    'column you are filtering
    FilterCol = 1
    'row with headers
    FilterRow = 1


    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With


    On Error GoTo progend


    'add filter sheet
    Set wsFilter = Sheets.Add
    
    With ws1Master
        .Activate
        .Unprotect Password:=""  'add password if needed
        
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column


        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
        
        'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
                      Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
                      
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
        
        'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value


        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
        
            'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
            
                'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
                
                SheetName = Trim(Left(FilterRange.Value, 31))
                
                On Error Resume Next
                Set wsParse = Sheets(SheetName)
                If Err.Number = 9 Then
                    'add new sheet
                    Set wsParse = Sheets.Add(after:=Worksheets(Worksheets.Count))
                    wsParse.Name = SheetName
                    Err.Clear
                End If
                On Error GoTo progend
                
                wsParse.Cells.Clear
                
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                                       CopyToRange:=wsParse.Range("A1"), Unique:=False
            
                wsParse.UsedRange.Columns.AutoFit
            End If
            
            Set wsParse = Nothing
        Next
        'return to master sheet
        .Select
    End With
    
progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With


    If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub

Code should be run from your master sheet & filters values in Column 1 (A) Code also assumes that the first row is a header row but these can be changed where shown in RED.

Hope Helpful.

Dave

 

[Andrea Schanz]

Thanks Dave. The issue I am having with your macro and mine is that my filter row is row 2, but I also need row 1 included on every worksheet as that is also a header row, just not a filter row. Can you alter your macro to include row 1?

 

[dmt32]

Thanks Dave. The issue I am having with your macro and mine is that my filter row is row 2, but I also need row 1 included on every worksheet as that is also a header row, just not a filter row. Can you alter your macro to include row 1?

Try this update & see if helps:

Sub FilterData()
    'DMT32
    Dim ws1Master As Worksheet, wsParse As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range
    Dim rowcount As Long
    Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
    Dim SheetName As String, msg As String




    'master sheet
    Set ws1Master = ActiveSheet


    'column you are filtering
    FilterCol = 1
    'row with headers
    FilterRow = 2


    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With


    On Error GoTo progend


    'add filter sheet
    Set wsFilter = Sheets.Add
    
    With ws1Master
        .Activate
        .Unprotect Password:=""  'add password if needed
        
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column


        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
        
        'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
                      Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
                      
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
        
        'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value


        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
        
            'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
            
                'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
                
                SheetName = Trim(Left(FilterRange.Value, 31))
                
                On Error Resume Next
                Set wsParse = Sheets(SheetName)
                If Err.Number = 9 Then
                    'add new sheet
                    Set wsParse = Sheets.Add(after:=Worksheets(Worksheets.Count))
                    wsParse.Name = SheetName
                    Err.Clear
                End If
                On Error GoTo progend
                
                wsParse.Cells.Clear
                
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                                       CopyToRange:=wsParse.Range("A2"), Unique:=False
                                       
                Datarng.Offset(-1, 1).EntireRow.Copy wsParse.Range("A1")
            
                wsParse.UsedRange.Columns.AutoFit
            End If
            
            Set wsParse = Nothing
        Next
        'return to master sheet
        .Select
    End With
    
progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With


    If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub

Dave

 

[Andrea Schanz]

Thanks again Dave. I figured out how to do it with my original macro by adding an additional xHeader as String:
ub parse_data()

'
'Create new sheet for each row based on column A
'
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
Dim xMonth As String
Dim xHeader As String
Set xSht = ActiveSheet
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A2:AO2"
xHeader = "A1:AO1"
xTRrow = xSht.Range(xTitle).Cells(1).Row
xMonth = "B1"

For I = 3 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
'A1 designates the cell to place the data
xSht.Range("A" & xHeader).EntireRow.Copy xNSht.Range("A1")
xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A2")

xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub