' This WBS Generator creates a work breakdown structure based on an Excel table.
' Created by Jerome Smith
' Published on https://sourceforge.net/projects/wbs-generator-good-plus-fast/
'
'Version 2.2 - July 13, 2019
'thanks to Mathieu Bilodeau on https://www.projectmanagement.com/deliverables/500955/WBS-Generator
'Fixed an error with conditional formatting and integer validation in Excel 365
'Version 2.1 - March 16, 2019
'Updated sniff test to check for English as the default language before execution.
'Version 2.0 - August 5, 2018
'Fixed misalignment issue when there are an odd number of WBS ID integers.
'Fixed drawing lines issue when x.01 was not the first WBS ID in level-3 boxes.
'Added option to draw connector lines or not.
'Created vertical/horizontal option for last field
'Added progress indicator
'Created Option to display legend
'Legend uses formulas to reflect real time updates in WBS Table headers.
'Version 1.1 - August 1, 2018
'Updated code to use two decimal points for the WBS ID to avoid n.1 and n.10 confusion.
' Version 1.0 - July 28, 2018
'First released
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
'---------------------------- WBS GENERATOR ----------------------------
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
Option Base 1
Option Explicit
Dim wsWBS As Worksheet, wsData As Worksheet, wsOptions As Worksheet, wsFormats As Worksheet
Dim tbl As ListObject, colCount As Integer, WBSarray As Variant
Dim iRow As Long, x As Long, i As Integer, j As Integer
Dim cell As Range, WBScolumn As Range, rng As Range
Dim WBS_AddressIDsString As String, WBS_AddressIDsRng As Range
Dim rowWBSID As Integer, middleWBSid As Double
Dim iDuplicates As Integer, iBlanks As Integer, iInteger As Integer, cntWBSintegers As Integer
Dim heading() As String, formattedData() As String
Dim rowIncrement As Integer, colIncrement As Integer
Dim drawConnectors As Boolean, LineElement1_colLeft, LineElement1_colRight, LineElement1_rowBottom, LineElement1_colMiddle
Dim bgPattern As String, bgColor As String, bgTint As String, fontColor As String
Dim lastFieldDisplay As String
Public Sub GenerateWBS()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
On Error GoTo 0
Prepare
Application.StatusBar = "Validation in progress..."
SniffTest
ResetWBS
PullWBSfromData
createConditionalFormats
Cells.ShrinkToFit = True
wsData.Activate
Cells(1, 1).Select
wsWBS.Activate
If drawConnectors = True Then
Application.StatusBar = "Drawing lines..."
Call drawLines_EastWest
Call drawLines_NorthSouth(xlEdgeRight, LineElement1_rowBottom + 1, LineElement1_colMiddle - 5)
End If
Cells(1, 1).Select
Cells.ColumnWidth = wsOptions.Range("b6").Value
Cells.EntireColumn.AutoFit
ActiveWindow.DisplayHeadings = wsOptions.Range("b8").Value2
ActiveWindow.DisplayGridlines = wsOptions.Range("b9").Value2
If wsOptions.Range("b10").Value = True Then Call createLegend
SendToErrorHandler:
Call CleanUp
End Sub
Private Sub Prepare()
Set wsData = sheetData
Set wsWBS = sheetWBS
Set wsOptions = sheetOptions
Set wsFormats = sheetFormats
Set tbl = wsData.ListObjects("WBS_Table")
getBodyBGandFontColor
wsData.Activate
rowWBSID = Cells(Rows.Count, 1).End(xlUp).row
Set WBScolumn = wsData.Range(Cells(2, 1), Cells(rowWBSID, 1))
Cells.FormatConditions.Delete
'does the data table start in cell A1?
If Left(tbl.HeaderRowRange.Address(0, 0), 2) <> "A1" Then
MsgBox "The table on the " & wsData.Name & " sheet doesn't start in cell A1. Delete any rows above or columns to the left of the data table and try agan.", _
vbCritical, "Set Data Table to Cell A1"
CleanUp
End If
With tbl.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("a1"), SortOn:=xlSortOnValues, Order:=xlAscending
.Header = xlYes
.Apply
End With
WBSarray = tbl.DataBodyRange
colCount = tbl.ListColumns.Count
drawConnectors = wsOptions.Range("b11").Value
lastFieldDisplay = wsOptions.Range("b7").Value
With WBScolumn.Interior 'clear shading
.Pattern = xlNone
.TintAndShade = 0
End With
highlightAllBlanksInDataTable
findMiddlePlotForLevel1
getDataFormats
End Sub
Private Sub ResetWBS()
wsWBS.Activate
Cells.Clear
Cells.ColumnWidth = 2.25
ActiveWindow.Zoom = 100
Cells(1, 1).Select
ActiveSheet.Shapes.SelectAll
Selection.Delete
End Sub
Private Function getBodyBGandFontColor()
bgPattern = wsOptions.Range("b5").Interior.PatternColorIndex
bgColor = wsOptions.Range("b5").Interior.Color
bgTint = wsOptions.Range("b5").Interior.TintAndShade
fontColor = wsOptions.Range("b5").Font.Color
End Function
Private Sub PullWBSfromData()
Dim colLevel2 As Double, rowLevel2 As Double
Dim colLevel3 As Double, rowLevel3 As Double
Dim IDpackage As Double, IDdeliverable As Double
Dim firstLevelThreeBox As Boolean
wsWBS.Activate
colLevel2 = 1
colLevel3 = 2
For x = LBound(WBSarray) To UBound(WBSarray)
'This is element level 3... WBS ID is not an integer
If WBSarray(x, 1) <> Int(WBSarray(x, 1)) Then
Call PlotWBS(rowLevel3, colLevel3, Format(WBSarray(x, 1), "0.00"))
Call createDetailsBox(rowLevel3, colLevel3, 3)
If drawConnectors = True Then
If firstLevelThreeBox = True Then
Call drawLines_NorthSouth(xlDiagonalDown, rowLevel3, colLevel3)
firstLevelThreeBox = False
Else
Call drawLines_NorthSouth(xlEdgeRight, rowLevel3, colLevel3)
End If
End If
rowLevel3 = Cells(Rows.Count, colLevel3 + 1).End(xlUp).row + 2 'start next box below last row in this column
IDdeliverable = WBSarray(x, 1)
'This is element level 2... WBS ID is an integer greater than 0
ElseIf WBSarray(x, 1) > 0 And val(WBSarray(x, 1)) = Int(WBSarray(x, 1)) Then
Call PlotWBS(rowLevel2, colLevel2, Format(WBSarray(x, 1), "0.00"))
Call createDetailsBox(rowLevel2, colLevel2, 2)
If drawConnectors = True Then Call drawLines_NorthSouth(xlEdgeRight, rowLevel2, colLevel2)
rowLevel3 = Cells(Rows.Count, colLevel2 + 1).End(xlUp).row + 2 'start next box below last row in this column
colLevel2 = colLevel2 + 13
IDpackage = WBSarray(x, 1)
firstLevelThreeBox = True
'This is element level 1... WBS ID is 0
ElseIf WBSarray(x, 1) = 0 Then
Call PlotWBS(1, middleWBSid, Format(WBSarray(x, 1), "0.00"))
Call createDetailsBox(1, middleWBSid, 1)
rowLevel2 = Cells(Rows.Count, middleWBSid + 1).End(xlUp).row + 3
LineElement1_rowBottom = rowLevel2 - 2
LineElement1_colMiddle = middleWBSid + 5
End If
'If ready for next Package, update deliverable column
If IDpackage > IDdeliverable And IDpackage > 1 Then colLevel3 = colLevel3 + 13
Application.StatusBar = x & " of " & UBound(WBSarray) & " boxes created..."
Next x
End Sub
Private Function findMiddlePlotForLevel1()
For x = LBound(WBSarray) To UBound(WBSarray)
If WBSarray(x, 1) > 0 And val(WBSarray(x, 1)) = Int(WBSarray(x, 1)) Then
cntWBSintegers = cntWBSintegers + 1
End If
Next x
LineElement1_colLeft = 6
LineElement1_colRight = cntWBSintegers * 13 - 8
middleWBSid = Int(cntWBSintegers * 13 / 2 - 5)
End Function
Private Sub PlotWBS(row As Double, col As Double, val As Double)
With wsWBS.Cells(row, col)
.Value = val
.NumberFormat = "0.00"
.Borders.LineStyle = xlContinuous
.Font.Bold = True
End With
End Sub
Private Sub getDataFormats()
'remember, Option Base 1 is set
Dim i As Integer, xData As Variant
wsData.Activate
i = 0
For Each xData In wsData.Rows(1).Cells
If xData.Value = "" Then Exit For
i = i + 1
ReDim Preserve heading(i) As String
heading(i) = xData.Value
Next xData
i = 0
For Each xData In wsData.Rows(2).Cells
If xData.Value = "" Then Exit For
i = i + 1
ReDim Preserve formattedData(i) As String
formattedData(i) = xData.NumberFormat
Next xData
End Sub
Private Sub createDetailsBox(row As Double, col As Double, level As Integer)
Dim x As Integer
Dim mergeArray() As Range
wsWBS.Activate
Set WBS_AddressIDsRng = wsWBS.Cells(row, col)
WBS_AddressIDsString = WBS_AddressIDsRng.Address
'Enter formulas and set define cells to merge
rowIncrement = 0
colIncrement = 1
For x = 2 To colCount
ReDim Preserve mergeArray(x) As Range
wsWBS.Cells(row + rowIncrement, col + colIncrement).Value = "=VLOOKUP(" & WBS_AddressIDsString & ",WBS_Table," & x & ",FALSE)"
'second to last detail
If x = colCount - 1 And lastFieldDisplay = "Vertical" Then
If colIncrement = 1 Then
colIncrement = 9
Set mergeArray(x) = wsWBS.Range(Cells(row + rowIncrement, col + 1), Cells(row + rowIncrement, col + 8))
ElseIf colIncrement = 5 Then
colIncrement = 9
Set mergeArray(x) = wsWBS.Range(Cells(row + rowIncrement, col + 5), Cells(row + rowIncrement, col + 8))
End If
'last detail
ElseIf x = colCount And lastFieldDisplay = "Vertical" Then
Set mergeArray(x) = wsWBS.Range(Cells(row + rowIncrement, col + colIncrement), Cells(row, col + colIncrement))
ElseIf x = colCount And lastFieldDisplay = "Horizontal" Then
If colIncrement = 1 Then
colIncrement = 9
Set mergeArray(x) = wsWBS.Range(Cells(row + rowIncrement, col + 1), Cells(row + rowIncrement, col + 8))
ElseIf colIncrement = 5 Then
colIncrement = 9
Set mergeArray(x) = wsWBS.Range(Cells(row + rowIncrement, col + 5), Cells(row + rowIncrement, col + 8))
End If
'details below title, left side
ElseIf rowIncrement > 0 And colIncrement = 1 Then
colIncrement = 5
Set mergeArray(x) = wsWBS.Range(Cells(row + rowIncrement, col + 1), Cells(row + rowIncrement, col + 4))
'details below title, right side
ElseIf rowIncrement > 0 And colIncrement = 5 Then
Set mergeArray(x) = wsWBS.Range(Cells(row + rowIncrement, col + 5), Cells(row + rowIncrement, col + 8))
rowIncrement = rowIncrement + 1
colIncrement = 1
'title, merged across
ElseIf rowIncrement = 0 And colIncrement = 1 Then
Set mergeArray(x) = wsWBS.Range(Cells(row, col + 1), Cells(row, col + 8))
rowIncrement = rowIncrement + 1
Else
Debug.Print "What is the else?"
End If
mergeArray(x).Select
'Format cells
Select Case x
Case 2 'title of details box
wsOptions.Range("b" & level + 1).Copy
Selection.PasteSpecial Paste:=xlPasteFormats
Case colCount 'last detail
If lastFieldDisplay = "Vertical" Then
With Selection
.NumberFormat = formattedData(x)
.Orientation = 90
.Borders.LineStyle = xlContinuous
End With
End If
Case Else 'all other details, format as source
On Error Resume Next
With Selection
.NumberFormat = formattedData(x)
.Interior.PatternColorIndex = bgPattern
.Interior.Color = bgColor
.Interior.TintAndShade = bgTint
.Font.Color = fontColor
End With
On Error GoTo 0
End Select
'merge cells
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = True
.Borders.LineStyle = xlContinuous
End With
Next
Erase mergeArray
End Sub
Private Sub createConditionalFormats()
Dim iInteger As Integer
Dim tblFormats_Conditional As ListObject
Set tblFormats_Conditional = sheetFormats.ListObjects("OptionsConditionalFormat_Table")
On Error Resume Next
For iInteger = 2 To Range("OptionsConditionalFormat_Table").Rows.Count + 1
Set rng = wsFormats.Range("a" & iInteger)
wsWBS.Cells.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=rng.Value
wsWBS.Cells.FormatConditions(wsWBS.Cells.FormatConditions.Count).SetFirstPriority
With wsWBS.Cells.FormatConditions(1).Font
.Color = rng.Font.Color
.ColorIndex = rng.Font.ColorIndex
.FontStyle = rng.Font.FontStyle
.Strikethrough = rng.Font.Strikethrough
.Underline = rng.Font.Underline
.ThemeColor = rng.Font.ThemeColor
.TintAndShade = rng.Font.TintAndShade
End With
With wsWBS.Cells.FormatConditions(1).Interior
.PatternColorIndex = rng.Interior.PatternColorIndex
.Color = rng.Interior.Color
.TintAndShade = rng.Interior.TintAndShade
End With
wsWBS.Cells.FormatConditions(1).StopIfTrue = False
Next iInteger
On Error GoTo 0
End Sub
Private Sub drawLines_EastWest()
With Range(wsWBS.Cells(LineElement1_rowBottom, LineElement1_colLeft), _
wsWBS.Cells(LineElement1_rowBottom, LineElement1_colRight)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
Private Function drawLines_NorthSouth(lineType As String, row As Double, col As Double)
With wsWBS.Cells(row - 1, col + 4).Borders(lineType)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Function
Private Sub createLegend()
Prepare
Dim wsLegend As Worksheet
Dim row As Integer, col As Integer
Dim lastRow As Long, lastCol As Long
Set wsLegend = sheetLegend
wsLegend.Activate
Cells.Clear
'create ID and first detail
wsLegend.Range("a1").Value = "ID"
wsLegend.Range("b1").Value = "=VLOOKUP(""WBS ID"",WBS_Table[#Headers], 2, false)"
'=VLOOKUP("WBS ID",WBS_Table[#Headers],2,FALSE)
wsOptions.Range("b2").Copy
wsLegend.Range("b1").PasteSpecial Paste:=xlPasteFormats
wsLegend.Range("a1").Borders.LineStyle = xlContinuous
'created remaining details, except for the last one
row = 2
col = 2
For i = 3 To colCount - 1
wsLegend.Cells(row, col).Value = "=VLOOKUP(""WBS ID"",WBS_Table[#Headers]," & i & ", false)"
If col = 2 Then 'column B
col = 3
Else 'column C
col = 2
row = row + 1
End If
Next i
'create last detail, determine if to merge vertical or not
If lastFieldDisplay = "Horizontal" Then
wsLegend.Cells(row, col).Value = "=VLOOKUP(""WBS ID"",WBS_Table[#Headers]," & i & ", false)"
wsLegend.Range("b1:c1").Merge
ElseIf lastFieldDisplay = "Vertical" Then
wsLegend.Cells(2, 4).Value = "=VLOOKUP(""WBS ID"",WBS_Table[#Headers]," & i & ", false)"
lastRow = wsLegend.UsedRange.Rows.Count
wsLegend.Range("d2:d" & lastRow).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = True
End With
wsLegend.Range("b1:d1").Merge
End If
'draw borders
Cells.EntireColumn.AutoFit
Cells.ShrinkToFit = True
lastRow = wsLegend.UsedRange.Rows.Count
lastCol = wsLegend.UsedRange.Columns.Count
wsLegend.Range(Cells(1, 2), Cells(lastRow, lastCol)).Borders.LineStyle = xlContinuous
'Merge detail if it's on the last row by itself
If wsLegend.Range("c" & lastRow).Value = "" Then
wsLegend.Range("b" & lastRow, "c" & lastRow).Merge
End If
'add instructions
wsLegend.Range("f1").Value = "<--"
wsLegend.Range("f2").Value = "This legend shows up on the WBS sheet as a linked image."
wsLegend.Range("f3").Value = "Changing the WBS Table headers will be reflected here."
wsLegend.Range("f4").Value = "The image you see here will appear on the linked image."
wsLegend.Range("f5").Value = "To enable/disable the legend display, go to the WBS Options page."
wsLegend.Columns("F:F").ColumnWidth = 60
'copy/paste linked image of Legend to WBS sheet
wsLegend.Range(Cells(1, 1), Cells(lastRow, lastCol)).Copy
wsWBS.Select
Range("b2").Select
ActiveSheet.Pictures.Paste(Link:=True).Select
Selection.ShapeRange.ScaleWidth 0.8, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
End Sub
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
'---------------------------- SNIFF TEST ----------------------------
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
Private Sub SniffTest()
'is Excel in English?
Dim lng As Long
lng = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Select Case lng
'English, see https://docs.microsoft.com/en-us/previous-versions/office/developer/office-2007/bb213877(v=office.12)
Case 1033, 2057
'do nothing
'not English
Case Else
MsgBox "Your default language for Excel is not English, which may or may not result in errors. Proceed at your own risk." & vbNewLine & vbNewLine & _
"Please contact me if you 'd like to localize this macro for your language." & vbNewLine & _
"For help changing your default language, search the internet for ""excel change default language"" for instructions.", _
vbInformation, "Known Issue - Language Settings"
End Select
'is WBS ID the first column in the data table
If tbl.ListColumns(1) <> "WBS ID" Then
MsgBox "The first column on the " & wsData.Name & " sheet's table must be titled ""WBS ID"".", vbCritical, "Invalid Column"
wsData.Activate
Cells(1, 1).Select
Call CleanUp
'does the wBS ID column only have numbers?
ElseIf WBS_OnlyNumbers = False Then
MsgBox "The WBS ID column on the " & wsData.Name & " sheet can only have numbers in the ""0.00"" format." & vbNewLine & vbNewLine & _
"Replace """ & Left(cell.Value, 15) & """ in cell " & cell.Address(False, False) & " with a valid number.", vbCritical, "Invalid WBS ID"
wsData.Activate
Cells(1, 1).Select
Call CleanUp
'are there duplicates in the WBS column of the data sheet?
ElseIf FindDuplicatesWBS = True Then
MsgBox "Remove the " & iDuplicates & " duplicate(s) in the WBS ID column of the " & wsData.Name & " sheet and try again." & _
vbNewLine & vbNewLine & "Verify you're not mixing up 1.1 and 1.01 and 1.10 (Microsoft Project will mix this up, for example).", _
vbCritical, "Duplicate WBS IDs"
wsData.Activate
Cells(1, 1).Select
Call CleanUp
'are there any blanks in the WBS column of the data sheet?
ElseIf findBlanksWBS = True Then
MsgBox "Remove the " & iBlanks & " blanks in the WBS ID column of the " & wsData.Name & " sheet and try again.", vbCritical, "Blanks in WBS ID Column"
wsData.Activate
Cells(1, 1).Select
Call CleanUp
'does the 0.0 WBS ID exist, to show the project level?
ElseIf WBS_ZeroExists = False Then
MsgBox "Add the 0.0 WBS ID to the table in the " & wsData.Name & " sheet to show the project level status.", vbCritical, "Missing Project WBS ID"
wsData.Activate
Cells(1, 1).Select
Call CleanUp
'do decimals have supporting intergers, i.e., does 1.1 have 1.0?
ElseIf doDecimalsHaveSupportingIntegers = False And iInteger <> 0 Then
MsgBox "Include WBS ID """ & iInteger & ".00"" in the " & wsData.Name & " sheet to maintain the hierarchical relationships of the WBS.", vbCritical, "Missing Level 2 WBS ID"
wsData.Activate
Cells(1, 1).Select
Call CleanUp
ElseIf doNumbersExistBetweenZeroAndOne = True Then
MsgBox "Remove all WBS ID's between 0 and 1, i.e., 0.xx."
wsData.Activate
Cells(1, 1).Select
Call CleanUp
'are there blanks in row 2 of the data table?
ElseIf doBlanksExist_DataTable_FirstDataRow = True Then
MsgBox "There are blanks in row 2 of the " & wsData.Name & " sheet." & vbNewLine & vbNewLine & _
"Fill in all blanks and format the cells how they'll appear on the " & wsWBS.Name & " sheet.", _
vbCritical, "Data Table Has Blanks"
wsData.Activate
Cells(1, 1).Select
Call CleanUp
End If
'CHECK THE OPTIONS PAGE
'Valid number for Column Width
If wsOptions.Range("b6").Value < 1 Or wsOptions.Range("b6").Value > 10 Then
wsOptions.Activate
wsOptions.Range("b6").Select
MsgBox "Enter a value between 1 and 10 in cell B6 of the " & wsOptions.Name & " sheet and try again.", _
vbCritical, "Invalid Entry"
Call CleanUp
End If
'Vertical or Horizontal value for Make last column…
If wsOptions.Range("b7").Value = "Horizontal" Or wsOptions.Range("b7").Value = "Vertical" Then
'do nothing
Else
wsOptions.Activate
wsOptions.Range("b7").Select
MsgBox "Enter Horizontal or Vertical in cell B7 of the " & wsOptions.Name & " sheet and try again.", _
vbCritical, "Invalid Entry"
Call CleanUp
End If
'True or false value for Display Excel headings
If wsOptions.Range("b8").Value = True Or wsOptions.Range("b8").Value = False Then
'do nothing
Else
wsOptions.Activate
wsOptions.Range("b8").Select
MsgBox "Enter TRUE or FALSE in cell B8 of the " & wsOptions.Name & " sheet and try again.", _
vbCritical, "Invalid Entry"
Call CleanUp
End If
'true or false value for Display Lines
If wsOptions.Range("b9").Value = True Or wsOptions.Range("B9").Value = False Then
'do nothing
Else
wsOptions.Activate
wsOptions.Range("b9").Select
MsgBox "Enter TRUE or FALSE in cell B9 of the " & wsOptions.Name & " sheet and try again.", _
vbCritical, "Invalid Entry"
Call CleanUp
End If
End Sub
Private Function doNumbersExistBetweenZeroAndOne()
For Each cell In WBScolumn
If cell.Value > 0 And cell.Value < 1 Then
doNumbersExistBetweenZeroAndOne = True
cell.Interior.ColorIndex = 3
Exit Function
End If
Next cell
End Function
Private Function doBlanksExist_DataTable_FirstDataRow() As Boolean
Dim i As Integer
i = 1
For i = 1 To tbl.ListColumns.Count
If IsEmpty(tbl.DataBodyRange.Cells(1, i)) = True Then
doBlanksExist_DataTable_FirstDataRow = True
End If
Next i
End Function
Private Function doDecimalsHaveSupportingIntegers() As Boolean
For Each cell In WBScolumn
If Right(Format(cell, "0.00"), 2) > 0 Then 'number to right of decimal > 0
If findText(Int(cell.Value)) = False Then
doDecimalsHaveSupportingIntegers = False
iInteger = Int(cell.Value)
cell.Interior.ColorIndex = 3
Exit Function
End If
End If
Next cell
End Function
Private Function findText(searchFor As String) As Boolean
Set rng = Cells.Find(What:=searchFor, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If rng Is Nothing Then
findText = False
Else
findText = True
End If
Set rng = Nothing
End Function
Private Function FindDuplicatesWBS() As Boolean
wsData.Activate
For Each cell In WBScolumn
If WorksheetFunction.CountIf(WBScolumn, cell.Value) > 1 Then
cell.Interior.ColorIndex = 3
iDuplicates = iDuplicates + 1
FindDuplicatesWBS = True
End If
Next
iDuplicates = iDuplicates / 2
End Function
Private Function findBlanksWBS() As Boolean
wsData.Activate
For Each cell In WBScolumn
If Trim(cell.Value) = "" Then
cell.Interior.ColorIndex = 3
iBlanks = iBlanks + 1
End If
Next cell
If iBlanks > 0 Then findBlanksWBS = True
End Function
Private Function WBS_ZeroExists() As Boolean
wsData.Activate
Dim zeroDotZero As Long
zeroDotZero = 0#
For Each cell In WBScolumn
If cell.Value = 0 Then WBS_ZeroExists = True
Exit Function
Next cell
End Function
Private Function WBS_OnlyNumbers() As Boolean
For Each cell In WBScolumn
If IsNumeric(cell) = False Then
WBS_OnlyNumbers = False
Exit Function
Else
WBS_OnlyNumbers = True
End If
Next cell
End Function
Private Sub highlightAllBlanksInDataTable()
Range(tbl).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=LEN(TRIM(A2))=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
'---------------------------- CLEAN UP ----------------------------
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
Private Sub CleanUp(Optional par1 As String, Optional par2 As String)
On Error Resume Next
Set tbl = Nothing
Set wsWBS = Nothing
Set wsData = Nothing
Set wsOptions = Nothing
Set WBScolumn = Nothing
Set WBS_AddressIDsRng = Nothing
Set rng = Nothing
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Select Case Err.Number
Case 0 'do nothing
Case Else
MsgBox Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Please report errors to https://sourceforge.net/u/jerome-smith01/profile/", _
vbCritical, "Unknown Error"
End Select
End
End Sub
