PDA

View Full Version : Solved: Unique Lists



Pam in TX
06-14-2007, 10:14 AM
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.....:bow:

Bob Phillips
06-14-2007, 11:57 AM
You have totally lost me. What is it not doing, and what is all that about column A/B mean?

Pam in TX
06-14-2007, 12:29 PM
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...... :dunno

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
06-14-2007, 01:56 PM
This does the copying, I will leave you to setup the formulae



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

Pam in TX
06-14-2007, 03:34 PM
Thanks, but it is the formulas transfering over that I am having the problem with.....

Pam in TX
06-16-2007, 05:03 AM
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
06-17-2007, 05:23 PM
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
06-17-2007, 06:12 PM
rbrhodes,

Thank you, thank you, thank you...... :bow: :bow: :bow: 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
06-17-2007, 07:50 PM
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
06-18-2007, 03:55 AM
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
06-18-2007, 01:02 PM
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
06-19-2007, 11:02 AM
Have used it several times today and it works great............. Thanks again......

rbrhodes
06-19-2007, 10:05 PM
Edit