Option Explicit
Sub CreateListing()
' -----------------------------------
' Declare Variables
' -----------------------------------
' Worksheet object that points to the stats worksheet.
Dim wsStats As Worksheet
' Used to iterate through List worksheets.
Dim wsLoop As Worksheet
' Used to iterate through branches in a range.
Dim rCell As Range
' Cell that anchors data in thr Stats worksheet.
Dim rTargetAnchorCell As Range
' Range that contains branches for a specific list.
Dim rListData As Range
' Address where data is located in List worksheet.
Dim sDataSourceAddress As String
' Variable holding the name of the Stat worksheet.
Dim sStatSheetName As String
' Keep count of how many rows have been transferred to the Stats worksheet.
Dim iBranchesTransferred As Long
' Used to determine how many rows of existing data exists that requiring clearing
Dim iRowsToClear As Long
' Collection of unique branches.
Dim colBranches As New Collection
' Used to access each entry in the collection.
Dim vItem As Variant
' For iterating through each item in the collection.
Dim iBranch As Long
' -----------------------------------
' Initialize Variables
' -----------------------------------
sStatSheetName = "Stats" '<= Change if the name of the stats sheet changes.
sDataSourceAddress = "K5:K38" '<= Change if range where list data is located changes.
Set wsStats = Worksheets(sStatSheetName)
Set rTargetAnchorCell = wsStats.Range("A3") '<= Change if the upperleftmost cell in
' the stats sheet changes.
' Initialize count of rows of List data that has been transferred.
iBranchesTransferred = 0
' -----------------------------------
' Clear the existing Data
' -----------------------------------
iRowsToClear = wsStats.Cells(Rows.Count, 1).End(xlUp).Row - rTargetAnchorCell.Row + 1
If iRowsToClear > 0 _
Then
rTargetAnchorCell.Resize(iRowsToClear, 1).Value = ""
rTargetAnchorCell.FormatConditions.Delete
End If
' --------------------------------------
' Process List Worksheets' Data
' --------------------------------------
For Each wsLoop In Worksheets
If UCase(wsLoop.Name) Like "LIST*" _
Then
Set rListData = wsLoop.Range(sDataSourceAddress)
For Each rCell In rListData
On Error Resume Next
colBranches.Add rCell.Value, rCell.Value
On Error GoTo 0
Next rCell
'
End If
Next wsLoop
' ------------------------------------
' Transfer Branches to Target
' ------------------------------------
For Each vItem In colBranches
iBranch = iBranch + 1
rTargetAnchorCell.Cells(iBranch).Value = vItem
Next
' -----------------------------------
' Format Transferred Data
' -----------------------------------
With rTargetAnchorCell.Resize(iBranch)
.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.Pattern = xlGray16
.PatternThemeColor = xlThemeColorDark1
.ColorIndex = xlAutomatic
.PatternTintAndShade = -0.349986266670736
End With
End With
End Sub
