Option Explicit
Private m_app As Object
Private m_bError As Boolean
Private m_psErrorDescription As String
Private UserRanges As Collection
Private UniqueValues() As New Scripting.Dictionary
Private OutputCollections As Collection
Private AddressLookupArray() As Object
Private Const ENABLE_SVG_VISUAL_CREATION As Boolean = False
Private Sub Main()
Set UserRanges = New Collection
Dim rng As Range
Dim index As Integer
Dim promptText As String
'On Error Resume Next
Application.DisplayAlerts = False
'get Ranges from user
' First Range
index = 1
promptText = "Select the values for List " & index & " (or hit Enter to finish)"
'rng = InputBox(prompt:=promptText, Title:=("List " & index), Type:=8)
Set rng = Application.InputBox(promptText, ("List " & index), , , , , , Type:=8)
'Dim rngTest As String
'rngTest = rng.Address
'MsgBox (rngTest)
If (rng Is Nothing) Then
MsgBox ("Process Cancelled.")
Application.DisplayAlerts = True
Exit Sub
End If
'MsgBox (UserRanges.Count)
'add range to collection and get next range
Do While (Not rng Is Nothing)
If (GetFullAddress(rng) = GetDefaultCell()) Then
'user is done selection ranges
Exit Do ' <----- exit loop
Else
UserRanges.Add (rng)
Set rng = Nothing
index = index + 1
promptText = "Select the values for List " & index & " (or hit Enter to finish)"
Set rng = Application.InputBox(promptText, ("List " & index), GetDefaultCell, , , , , Type:=8)
MsgBox (UserRanges.Count)
End If
Loop
If (UserRanges.Count() = 1) Then
MsgBox ("Error: Only one list is selected. Process Cancelled.")
Application.DisplayAlerts = True
Exit Sub ' <-- Early exit
End If
'Create the dictionary of unique values for each range
Dim cell As Range
ReDim UniqueValues(UserRanges.Count)
For index = 1 To UserRanges.Count()
Set UniqueValues(index) = New Scripting.Dictionary
For Each cell In UserRanges.Item(index)
If (Not UniqueValues(index).Exists(CStr(cell.value))) Then
UniqueValues(index).Add (CStr(cell.value)), cell.value
End If
Next cell
Next
'create the ouput collections
' NOTE: Each output collection corresponds to an ouput column there will be 2^N-1 output collections, where N = # of lists
' Each output collection will be keyed by a binary number (eg 01, 10, 11 for two lists). The collection's key indicates
' which lists its members belong to.
' Example:
' -Example 1: "01" => the members belong to list 2, but not to list 1
' -Exmaple 2: "101" => the members belong to lists 1 and 3, but not 2
Set OutputCollections = New Collection
Dim temp As Collection
For index = 1 To (2 ^ UserRanges.Count() - 1)
Set temp = New Collection
OutputCollections.Add temp, Dec2Bin(index, UserRanges.Count())
Next
'cycle through each UserRange and build Collections
'NOTE: We will also build the address lookup array
'get total number of cells in all UserRanges
Dim totalCells As Integer
totalCells = 0
For Each rng In UserRanges
totalCells = totalCells + rng.Count
Next rng
'create address lookup Array with appropriate Dimensions
ReDim AddressLookupArray(totalCells, 3)
Dim key As String
index = 1
Dim sheetName As String
For Each rng In UserRanges
'get sheetname with "!" (and tick marks if necessary)
sheetName = rng.Worksheet.Name
If (InStr(1, sheetName, " ")) Then
sheetName = "'" & sheetName & "!"
Else
sheetName = sheetName & "!"
End If
For Each cell In rng
If (Len(cell.value) <> 0) Then ' only consider non-blanks
key = GetOutputListKey(CStr(cell.value))
OutputCollections.Item(key).Add cell.value, (CStr(cell.value)) 'NOTE: a key must be a string
'add address lookup array and color original cell
AddressLookupArray(index, 1) = sheetName & cell.Address
AddressLookupArray(index, 2) = cell.value
AddressLookupArray(index, 3) = "'" & key ' tick marks to ensure its formatted as a string
cell.Interior.ColorIndex = GetColorCode(key)
index = index + 1
End If
Next cell 'cell in rng
Next rng 'rng in userRanges
'Output: Special Cases (identical or disjointed lists)
'NOTE: These special cases do not require and output sheet
If (ListsAreDisjoint()) Then ' disjoint lists
MsgBox ("The lists do not overlap.")
Application.DisplayAlerts = True
Exit Sub '<-- Early exit
ElseIf (ListsAreIdentical()) Then
MsgBox ("The lists are identical.")
Application.DisplayAlerts = True
Exit Sub '<-- Early Exit
End If
'Create Output Page
'add new worksheet
Dim outputSheet As New Worksheet
With Application.ActiveWorkbook.Worksheets
outputSheet = .Add(after:=Application.ActiveWorkbook.Worksheets(.Count))
End With
'name new worksheet
Dim wsTemp As Worksheet
Dim newName As String
Dim nameBase As String
nameBase = "List Comparison Summary"
newName = nameBase
index = 2
Err.Clear
wsTemp = Application.ActiveWorkbook.Worksheets(newName)
Do While (Err.Number = 0)
newName = nameBase & " (" & index & ")"
wsTemp = Application.ActiveWorkbook.Worksheets(newName)
index = index + 1
Loop
Err.Clear
outputSheet.Name = newName
'output page: dump output collection
'NOTE: Will do this in two parts: first, the single-list collections, then the rest
'dump single list collections
'NOTE: since "100" actually represents List 1 (not List 3, as might have been expected), we have to do this in decending order.
For index = UserRanges.Count() - 1 To 0 Step -1
DumpCollection outputSheet, Dec2Bin((2 ^ (index)), UserRanges.Count)
Next
'dump rest of output collections
For index = 1 To (2 ^ (UserRanges.Count - 1))
If (Not IsPowerOf2(index, UserRanges.Count)) Then
DumpCollection outputSheet, Dec2Bin(index, UserRanges.Count)
End If
Next
'center the text for the counts on the first row
rng = outputSheet.Range("A1")
rng = outputSheet.Range(rng, rng.End(xlToRight))
rng.HorizontalAlignment = xlCenter
'Ouput Page: location lookup table
Dim col As Integer
Dim firstCell As Range
Dim sortKey1 As Range
Dim sortKey2 As Range
Dim firstKeyCell As Range
Dim rangeToColor As Range
Dim currentColor As Object
Dim numRows As Integer
If (UBound(AddressLookupArray, 1) >= 65000) Then 'don't try to dump too many rows
MsgBox ("Lookup tables are not generated when more than 65,000 cells are involved.")
Else
'dump headings for addressArrayLookup
col = 1 + GetFirstUsedColumn(outputSheet)
firstCell = outputSheet.Cells.Default(1, col)
firstCell.value = "Location Lookup Table"
'move down one row to insert the second level heading
firstCell = firstCell.Offset(1, 0)
firstCell.value = "Address"
firstCell.Offset(0, 1).value = "Value"
'dump addresslookuparray values onto output sheet
firstCell = firstCell.Offset(1, 0)
rng = FillRange(firstCell, AddressLookupArray)
'sort range if more than two rows (ie, 4 cells)
If (rng.Count > 4) Then
firstKeyCell = firstCell.Offset(0, 2) ' top cell of first sort key range
sortKey1 = outputSheet.Range(firstKeyCell, firstKeyCell.End(xlDown)) ' sort first by key in column 3
sortKey2 = sortKey1(0, -1) 'then sort by value
rng.Sort Key1:=sortKey1, key2:=sortKey2
'resize column width for lookup table's address column
sortKey1.Offset(0, -2).EntireColumn.AutoFit
'color the lookup table in blocks, based on key column
numRows = OutputCollections.Item(firstKeyCell.value).Count
rangeToColor = outputSheet.Range(firstCell, firstCell.Offset(numRows - 1, 1))
currentColor = GetColorCode(firstKeyCell.value)
Do While (currentColor <> "")
'NOTE: since the "All Lists" category is at the bottom of the sorted lookup table, CurrentColor will be
' the null stringeither when it has reached the last category, or when the coloring will be off
' anyway due to having too many lists
rangeToColor.Interior.ColorIndex = currentColor
firstKeyCell = firstKeyCell.Offset(numRows, 0) 'get next key cell
numRows = OutputCollections.Item(firstKeyCell.value).Count 'get next numrows
rangeToColor = outputSheet.Range(firstKeyCell.Offset(0, -2), firstKeyCell.Offset(numRows - 1, 1))
currentColor = GetColorCode(firstKeyCell.value)
Loop
'remove key column
sortKey1.Delete
End If
End If
'outputpage: NOTE: Note of coloring for 5 or more lists
If (UserRanges.Count > 4) Then
outputSheet.Rows.Default("1:2").Insert (xlDown)
outputSheet.Range("A1").value = "Warning: Coloring for 5 or more lists is not Exhaustive."
End If
'Create SVG Visual File
'read Template Controls
Dim contents As String
Dim templateFolder As String
Dim templateFullPath As String
Dim bCreateSvgVisual As Boolean
bCreateSvgVisual = False
templateFolder = "\\alb-fs1\Dept\EFI\Shared\Projects\State Assoc Clients\Product Management\programming\Add-ins\Source Code\List Comparison 3\SVG Templates\"
If (UserRanges.Count = 2) Then
bCreateSvgVisual = True
templateFullPath = templateFolder & "SVG Visual 2.svg"
ElseIf (UserRanges.Count = 3) Then
bCreateSvgVisual = True
templateFullPath = templateFolder & "SVG Visual 3.svg"
End If
'only create the SVG file if we are working with two or three lists
Dim svgVisualFolder As String
Dim svgVisualFullPath As String
Dim fso As New FileSystemObject
Dim styleSheetPath As String
Dim linkRange As Range
If (bCreateSvgVisual And ENABLE_SVG_VISUAL_CREATION) Then
ReadFromTextFile templateFullPath, contents
'replace template placeholders with appropriate text
For index = 1 To (2 ^ (UserRanges.Count) - 1)
key = Dec2Bin(index, UserRanges.Count)
contents = Replace(contents, "#" & key & "#", OutputCollections.Item(key).Count)
Next
'create output file and copy sylesheet.css...
'get outputfile path
svgVisualFolder = ActiveWorkbook.Path & "\"
svgVisualFullPath = svgVisualFolder & "SVG Visual.svg"
'write output file
WriteToTextFile svgVisualFullPath, contents
'copy stylesheet to appropriate folder (if a file by that name already exists, delete it)
styleSheetPath = svgVisualFolder & "stylesheet.css"
If (fso.FileExists(styleSheetPath)) Then
fso.DeleteFile (styleSheetPath)
End If
fso.CopyFile templateFolder & "stylesheet.css", styleSheetPath
'create SVG Visual Link
col = 4 + GetFirstUsedColumn(outputSheet)
linkRange = outputSheet.Cells.Default(1, col)
outputSheet.Hyperlinks.Add anchor:=linkRange, Address:=svgVisualFullPath, TextToDisplay:="SVG Visual"
End If
Application.DisplayAlerts = True
outputSheet.Select
'On Error GoTo 0
End Sub
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks