Solved: Unique Lists

[Pam in TX]

I am VERY new to writing macros and have a problem I need to experts to help me with??. It has to do with unique lists?.

I have 2 different sets of code (file attached) that almost do everything I need it to do?.. In my workbook I have a worksheet (actual title) that I need to create additional sheets from based on unique information in column B. At the bottom of the worksheet (a few rows below the last one with unique information) there are 9 rows which contain additional information and the bottom 7 rows have ?countif? formulas that reads information in the above rows. The first set of code (PagesbyDescription) works only if my unique information is in column A, and creates unique sheets, and the bottom sets of rows keeps the formulas, but doesn?t recalculate based on the new information?. When I try to get it to read from column B it does give me sheets but they are empty???? The second set of code (SplitIntoMultipleSheetsBasedOnColumn) sorts correctly based on column B, but doesn?t bring over the bottom set of rows at all?.

Thank you in advance for your assistance?.. It is muchly appreciated?? I am so glad to have found this forum.....

[Bob Phillips]

You have totally lost me. What is it not doing, and what is all that about column A/B mean?

[Pam in TX]

You have totally lost me. What is it not doing, and what is all that about column A/B mean?

Sorry I thought I had explained it as simply as possible......

My unique information is in column B (Teacher)....

I need one of the following:
The code set (Pagesbydescription) to work on column B, instead of A and I need it to recalculate the bottom 7 rows which contain the formulas....

OR
The code set (SplitIntoMultipleSheetsBasedOnColumn) to add on the bottom 9 rows and recalculate the bottom 7 rows which contain the formulas.........

Thanks again.............

[Bob Phillips]

This does the copying, I will leave you to setup the formulae

[vba]

Sub PagesByDescription()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet

Set wSheetStart = Worksheets("Worksheet")
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete
On Error GoTo 0

Worksheets.Add().Name = "UniqueList"
wSheetStart.AutoFilterMode = False
With wSheetStart
Set rRange = .Range(.Range("B1"), .Range("B65536").End(xlUp))
End With

With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A1"), True

Set rRange = .Range(.Range("A2"), .Range("A65536").End(xlUp))
End With

For Each rCell In rRange
wSheetStart.Range("A:CI").AutoFilter 2, rCell.Value
On Error Resume Next
Worksheets(rCell.Value).Delete
On Error GoTo 0
Worksheets.Add.Name = rCell.Value
wSheetStart.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next rCell

With wSheetStart
.AutoFilterMode = False
.Activate
End With

On Error GoTo 0
Application.DisplayAlerts = True
End Sub
[/vba]

[Pam in TX]

Thanks, but it is the formulas transfering over that I am having the problem with.....

[Pam in TX]

bumping for additional thoughts and assistance....

Realized an error in the original post..... the formulas do NOT transfer over.... sorry for the confusion....

xld, your macro works the same way as the second one that I was using.... It doesn't bring over the bottom set of rows at all....

[rbrhodes]

Hi Pam,

I've added to XLD's code to bring the formulas over and recalculate them...

Note: If you insert or delete Columns in the master sheet "Worksheet" you will have to update the range reference for the formulas in the sub. Right now it is set for U and V (It's commented in the sub) simply change the letters in the quotes and you're done.

Option Explicit
Sub PagesByDescription()
Dim fRow As Long
Dim lRow As Long
Dim lCol As Long
Dim cKey As Long
Dim rKey As Long
Dim pCol As String
Dim pCol2 As String
Dim rCell As Range
Dim rRange As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
 
    'create object
    Set wSheetStart = Worksheets("Worksheet")
    'errors are handled
    On Error Resume Next
    'turn off alerts and screen refresh till done
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    'delete old sheets
    For Each wSheet In Worksheets
        If wSheet.Name <> "Worksheet" Then
            wSheet.Delete
        End If
   Next wSheet
    'enable errors
    On Error GoTo 0
    'add Unique list sheet
    Worksheets.Add().Name = "UniqueList"
    'turn off Autofilter
    wSheetStart.AutoFilterMode = False
    'set range to work with
    With wSheetStart
        Set rRange = .Range(.Range("B1"), .Range("B65536").End(xlUp))
    End With
 
    With Worksheets("UniqueList")
        'copy filtered list of unique to temp sheet
        rRange.AdvancedFilter xlFilterCopy, , _
        Worksheets("UniqueList").Range("A1"), True
        'set range to work with
        Set rRange = .Range(.Range("A2"), .Range("A65536").End(xlUp))
    End With
 
    For Each rCell In rRange
        'filter with item from temp sheet
        wSheetStart.Range("A:CI").AutoFilter 2, rCell.Value
        'allow error
        On Error Resume Next
        'delete temp list item
        Worksheets(rCell.Value).Delete
        'enable errors
        On Error GoTo 0
        'add sheet named with item
        Worksheets.Add.Name = rCell.Value
        'copy filtered data to added sheet
        wSheetStart.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
        'fit cols
        ActiveSheet.Cells.Columns.AutoFit
    Next rCell
 
    With wSheetStart
        'turn off autofilter
        .AutoFilterMode = False
        'activate orig sheet
        .Activate
    End With
 
    'don't need it anymore
    Worksheets("UniqueList").Delete
    'enable erros
    On Error GoTo 0
    lRow = Range("A65536").End(xlUp).Row + 1
    'find formula row
    rKey = Range("A" & lRow & ":IV65536").Find("KEY").Row - 1
    'paste formula rows to each sheet
    For Each wSheet In Worksheets
        If wSheet.Name <> "Worksheet" Then
            lRow = wSheet.Range("A65536").End(xlUp).Row + 3
            'copy/paste them
            wSheetStart.Range(Cells(rKey, 1).Address, Cells(rKey + 8, 1)).EntireRow.Copy _
                Destination:=wSheet.Cells(lRow, 1)
            'build correct row for formulas
            fRow = lRow + 2
 
    'If Columns inserted/deleted then change these
            pCol = "U"
            pCol2 = "V"
    'end change
 
            'update the formula ranges starting in Col 21 ("U")
            With wSheet
                .Cells(fRow, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",0)"
                .Cells(fRow + 1, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",""A"")"
                .Cells(fRow + 2, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",""B"")"
                .Cells(fRow + 3, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",""C"")"
                .Cells(fRow + 4, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",""D"")"
                .Cells(fRow + 5, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",""E"")"
                'get last col to copy to
                lCol = Cells(lRow, 256).End(xlToLeft).Column
                'copy the formulas across
                .Range(Cells(fRow, pCol).Address, Cells(fRow + 5, pCol).Address).Copy _
                    Destination:=.Range(Cells(fRow, pCol2).Address, Cells(fRow + 5, lCol).Address)
                'redo for "Sum"
                Calculate
                'reset col width for sums
                .Range(Cells(fRow - 2, pCol).Address, Cells(fRow + 6, lCol).Address).Columns.AutoFit
            End With
        End If
    Next wSheet
 
    'cleanup
    Set rCell = Nothing
    Set rRange = Nothing
    Set wSheet = Nothing
    Set wSheetStart = Nothing
 
    'reset
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

[Pam in TX]

rbrhodes,

Thank you, thank you, thank you...... You are awesome....

Question: I noticed that it changed the highlighted cells on the worksheet and all the additional sheets..... Is there an easy way to leave the highlighted cells the way they were? No big deal if not, just curious....

Thanks again for taking the time to do this...... I really appreciate it..........

[rbrhodes]

Hi Pam,

This uses Pastespecial instead...

Option Explicit
Sub PagesByDescription()
Dim fRow As Long
Dim lRow As Long
Dim lCol As Long
Dim cKey As Long
Dim rKey As Long
Dim pCol As String
Dim pCol2 As String
Dim rCell As Range
Dim rRange As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
     
    'create object
    Set wSheetStart = Worksheets("Worksheet")
    'errors are handled
    On Error Resume Next
    'turn off alerts and screen refresh till done
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    'delete old sheets
    For Each wSheet In Worksheets
        If wSheet.Name <> "Worksheet" Then
            wSheet.Delete
        End If
   Next wSheet
    'enable errors
    On Error GoTo 0
    'add Unique list sheet
    Worksheets.Add().Name = "UniqueList"
    'turn off Autofilter
    wSheetStart.AutoFilterMode = False
    'set range to work with
    With wSheetStart
        Set rRange = .Range(.Range("B1"), .Range("B65536").End(xlUp))
    End With
     
    With Worksheets("UniqueList")
        'copy filtered list of unique to temp sheet
        rRange.AdvancedFilter xlFilterCopy, , _
        Worksheets("UniqueList").Range("A1"), True
        'set range to work with
        Set rRange = .Range(.Range("A2"), .Range("A65536").End(xlUp))
    End With
     
    For Each rCell In rRange
        'filter with item from temp sheet
        wSheetStart.Range("A:CI").AutoFilter 2, rCell.Value
        'allow error
        On Error Resume Next
        'delete temp list item
        Worksheets(rCell.Value).Delete
        'enable errors
        On Error GoTo 0
        'add sheet named with item
        Worksheets.Add.Name = rCell.Value
        'copy filtered data to added sheet
        wSheetStart.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
        'fit cols
        ActiveSheet.Cells.Columns.AutoFit
    Next rCell
     
    With wSheetStart
        'turn off autofilter
        .AutoFilterMode = False
        'activate orig sheet
        .Activate
    End With
     
    'don't need it anymore
    Worksheets("UniqueList").Delete
    'enable erros
    On Error GoTo 0
    lRow = Range("A65536").End(xlUp).Row + 1
    'find formula row
    rKey = Range("A" & lRow & ":IV65536").Find("KEY").Row - 1
    'paste formula rows to each sheet
    For Each wSheet In Worksheets
        If wSheet.Name <> "Worksheet" Then
            lRow = wSheet.Range("A65536").End(xlUp).Row + 3
            'copy/paste them
            wSheetStart.Range(Cells(rKey, 1).Address, Cells(rKey + 8, 1)).EntireRow.Copy _
                Destination:=wSheet.Cells(lRow, 1)
            'build correct row for formulas
            fRow = lRow + 2
    
    'If Columns inserted/deleted then change these
            pCol = "U"
            pCol2 = "V"
    'end change
    
            'update the formula ranges starting in Col 21 ("U")
            With wSheet
                .Cells(fRow, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",0)"
                .Cells(fRow + 1, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",""A"")"
                .Cells(fRow + 2, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",""B"")"
                .Cells(fRow + 3, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",""C"")"
                .Cells(fRow + 4, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",""D"")"
                .Cells(fRow + 5, pCol) = "=Countif(" & pCol & "2:" & pCol & lRow - 3 & ",""E"")"
                'get last col to copy to
                lCol = Cells(lRow, 256).End(xlToLeft).Column
                'copy the formulas across
                .Range(Cells(fRow, pCol).Address, Cells(fRow + 5, pCol).Address).Copy
 
'using Pastespecial instead of Destination
                
                .Range(Cells(fRow, pCol2).Address, Cells(fRow + 5, lCol).Address).PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=False
 
                'redo for "Sum"
                Calculate
                'reset col width for sums
                .Range(Cells(fRow - 2, pCol).Address, Cells(fRow + 6, lCol).Address).Columns.AutoFit
            End With
        End If
    Next wSheet
    
    'cleanup
    Set rCell = Nothing
    Set rRange = Nothing
    Set wSheet = Nothing
    Set wSheetStart = Nothing
    
    'reset
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

[Pam in TX]

Thanks.....

I can't tell any difference in how it runs though..... I still end up with all the answers in the key on the A row highlighted.... Other than that it works fine.... I need to figure out how to get them to stay highlighted to match the key row (preferred) or not highlight at all....

Thanks again...... You are wonderful......

[Pam in TX]

Ok, now that's wierd...... I just ran this again at work and it worked perfectly.....

I am going to wait a little while to mark this as solved though.... Thanks a million rbrhodes......

[Pam in TX]

Have used it several times today and it works great............. Thanks again......

[rbrhodes]

Edit