Excel

Excel Toolbox

Over the past years, I have learned some valuable Excel VBA tricks to help automate tasks. The file below contains some methods and UDF's to make life in Excel much easier.

Download Excel File

Fast Option for Matching Keys, then Returning Data

Good Sites for explaining Dictionaries / Collections:
https://excelmacromastery.com/vba-dictionary/
http://www.snb-vba.eu/VBA_Dictionary_en.html
https://sites.google.com/site/beyondexcel/project-updates/datadictionaryinvba-completesyntaxdocumentation

SQL: Link to Template code for importing...
https://www.linkedin.com/pulse/ado-function-query-most-common-data-sources-michael-blackman

Template: Add Unique words on spreadsheet to dictionary.

Dim Ws1 As Long, R1 As Long, R2 As Long, iRe1 As Long, iCe1 As Long, aData() As Variant, iHeader1 As Long
Dim Ws2 As Long, iRe2 As Long, iCe2 As Long, aDump() As Variant, iHeader2 As Long
dim iTestCol as Long
Dim aCell As Variant, sWord As String, iLoop As Long, Destination as Range

'Need udf(!) [udf_ContainsNum][udf_CleanSpaces]

'============================================================================================================
Ws1 = Worksheets("Item_Info").Index
Ws2 = Worksheets("Test").Index
iHeader1 = 1: iHeader2 = 1

Worksheets(Ws1).Select
iCe1 = Worksheets(Ws1).Cells(1, 1).End(xlToRight).Column
iRe1 = Worksheets(Ws1).Cells(1048576, 1).End(xlUp).Row
iTestCol = 2
'============================================================================================================

'Assign the arrays:
'============================================================================================================
Worksheets(Ws1).Select 'Range Array - Source Data
aData = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
'============================================================================================================

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

'Loop through Range Array
For R1 = LBound(aData) To UBound(aData)
DoEvents
    '==========================================================================================================
    'String array that holds each CELL value
    aCell = Split(udf_CleanSpaces(aData(R1, 1)), " ")
    '==========================================================================================================
    '==========================================================================================================
    For iLoop = LBound(aCell) To UBound(aCell)
        For R2 = 1 To 1
            'Individual word to test/add
            sWord = aCell(iLoop)

            '==================================================================================================
            If DictWordList.Exists(sWord) = True Then Exit For           'GAME CHANGER!
            If IsNumeric(sWord) = True Then Exit For
            If Len(sWord) < 3 Then Exit For
            If Len(Replace(sWord, "-", "", 1, , vbTextCompare)) < 3 Then Exit For
            If InStr(1, sWord, "|", vbTextCompare) <> 0 Then Exit For
            If udf_ContainsNum(sWord) = True Then Exit For
            '==================================================================================================

                'Load Valid Words
                If DictWordList.Exists(sWord) = False Then DictWordList.Add Key:=sWord, Item:=DictWordList.Count + 1

            '==================================================================================================
        Next R2
    Next iLoop
    '==========================================================================================================
Next R1
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

'dump results-------------------------------------------------------------------------
Worksheets(Ws2).Select
Cells.Clear
'==============================================================
Set Destination = Range(Worksheets(Ws2).Cells(1, 3).Address)
Destination.Resize(UBound(aEnglish, 1), UBound(aEnglish, 2)).Value = aEnglish
'==============================================================

Function udf_CleanSpaces(myString As Variant) As String
Dim sCSword As String
sCSword = myString
If sCSword = "" Then Exit Function

'Fix backslash
sCSword = Replace(sCSword, "/", " ", 1, , vbTextCompare)
sCSword = Replace(sCSword, " ", " ", 1, , vbTextCompare)

'Fix dash
sCSword = Replace(sCSword, "-", " ", 1, , vbTextCompare)
sCSword = Replace(sCSword, " ", " ", 1, , vbTextCompare)

'Fix pipe
sCSword = Replace(sCSword, "|", " ", 1, , vbTextCompare)
sCSword = Replace(sCSword, " ", " ", 1, , vbTextCompare)

'Fix comma
sCSword = Replace(sCSword, ",", " ", 1, , vbTextCompare)
sCSword = Replace(sCSword, " ", " ", 1, , vbTextCompare)

'Fix period
sCSword = Replace(sCSword, ".", " ", 1, , vbTextCompare)
sCSword = Replace(sCSword, " ", " ", 1, , vbTextCompare)

'Fix period
sCSword = Replace(sCSword, """", " ", 1, , vbTextCompare)
sCSword = Replace(sCSword, " ", " ", 1, , vbTextCompare)

udf_CleanSpaces = sCSword
End Function

Sub Template_AddColumnReferences()
'Note: This is used to find/replace each location when creating a new object - used "5" instead of 'one' to ensure that find/replace does not accidentally change hard coded values

'==============================================================
'Set ojbect refernces
Dim iSupplier5 As Long
Dim aSupplier5() As Variant
'==============================================================
'==============================================================
'Reset object Column Reference
iSupplier5 = 0
'==============================================================

'==============================================================
Worksheets(Ws5).Select
'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Find [] header (Change three-object locations + two-string locations + one-default column reference)
        iSupplier5 = CheckHeader("Supplier", Ws5, iHeader5, iCe5)
        If iSupplier5 = 0 Then iSupplier5 = Application.InputBox(Prompt:="Which Column contains [Supplier] data?", Title:="Specify Column by Clicking on ANY Cell within that Column", Default:=Cells(1, 1).Address, Type:=8).Column
'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'==============================================================

'==============================================================
'Test to ensure that header Column Definition was found
If iSupplier5 = 0 Then
'==============================================================

'==============================================================
'Define Arrays(Ws5)
Worksheets(Ws5).Select

aSupplier5 = Range(Worksheets(Ws5).Cells(iHeader5, iSupplier5).Address, Worksheets(Ws5).Cells(iRe5, iSupplier5).Address)
'==============================================================

'==============================================================
'Release memory
Erase aSupplier5:
'==============================================================

End Sub

Sub ReduceColumnTo_Strips()
'--------------------------------------------------------------------------------------------------------------------------------
'Disclaimer: Setting up Ws1 to apply to the active worksheet
'            Assumes that Row1 is the header row (no allowance set up if it resided in a different row)
'Note: User can use the same column for each prompt so that results are placed in the same column as the column to be cleaned
'--------------------------------------------------------------------------------------------------------------------------------

Dim Ws1 As Long, iHeader1 As Long, R1 As Long, R2 As Long, iRe1 As Long, iCe1 As Long, rRange As Range
Dim Ws2 As Long, iCe2 As Long, iRe2 As Long
Dim iColClean As Long, iColDump As Long
Dim aColClean() As Variant, aColDump() As Variant
Dim Destination As Range
'==============================================================
Ws1 = ActiveSheet.Index
'==============================================================
'Worksheets(Ws1).Select
iRe1 = Worksheets(Ws1).Cells(Rows.Count, 1).End(xlUp).Row
iCe1 = Worksheets(Ws1).Cells(1, Columns.Count).End(xlToLeft).Column
iHeader1 = 1
'==============================================================

'==============================================================
'Prompt user for column locations:
Set rRange = Application.InputBox(Prompt:="What Column contains the data you want to clean?", Title:="Specify Column by Clicking on ANY Cell within that Column", Default:=Cells(1, 1).Address, Type:=8)
iColClean = rRange.Column

Set rRange = Application.InputBox(Prompt:="What Column do you want to place the [Cleaned] results in?", Title:="Specify Column by Clicking on ANY Cell within that Column", Default:=Cells(1, iCe1 + 1).Address, Type:=8)
iColDump = rRange.Column
'==============================================================

'==============================================================
'Update the Last Row based on the Col Location that the user wants to clean
iRe1 = Worksheets(Ws1).Cells(Rows.Count, iColClean).End(xlUp).Row
'==============================================================

'==============================================================
'Define Arrays
aColClean = Range(Worksheets(Ws1).Cells(iHeader1, iColClean).Address, Worksheets(Ws1).Cells(iRe1, iColClean).Address)
aColDump = Range(Worksheets(Ws1).Cells(iHeader1, iColDump).Address, Worksheets(Ws1).Cells(iRe1, iColDump).Address)
'==============================================================

'==============================================================
'Load Cleaned data
For R1 = LBound(aColClean) + 1 To UBound(aColClean)
DoEvents
Application.StatusBar = R1
    aColDump(R1, 1) = Strip(aColClean(R1, 1))
Next R1

'Add header
aColDump(1, 1) = aColClean(1, 1)
'==============================================================

'==============================================================
Set Destination = Range(Worksheets(Ws1).Cells(iHeader1, iColDump).Address)
Destination.Resize(UBound(aColDump, 1), UBound(aColDump, 2)).Value = aColDump
'==============================================================
Application.StatusBar = ""
MsgBox "Done"
End Sub

Public Function Strip(myString As Variant) As String
Dim myLen As Long
Dim myStrLoop As Long
Dim myTestStr As String
Dim myResult As String

myLen = Len(myString)
For myStrLoop = 1 To myLen
    myTestStr = Mid(myString, myStrLoop, 1)
    If myTestStr >= "0" And myTestStr <= "9" = True Then
        myResult = myResult & myTestStr
    ElseIf myTestStr >= "a" And myTestStr <= "z" = True Then
        myResult = myResult & myTestStr
    ElseIf myTestStr >= "A" And myTestStr <= "Z" = True Then
        myResult = myResult & myTestStr
    ElseIf myTestStr = "-" Then
        myResult = myResult & myTestStr
    Else
    End If
Next myStrLoop
Strip = myResult
End Function

Public Function AllAlpha(myString As Variant) As Boolean
'Loops through each Char in string. If Alpha Characters are found, sets to False

Dim iLoop As Long

AllAlpha = True

For iLoop = 1 To Len(myString)
    If Mid(myString, iLoop, 1) Like "[0-9]" Then
        AllAlpha = False
        Exit Function
    End If

Next iLoop
End Function

Function AlphuSku(myString As Variant, sMid As Variant, sLeft As Variant, sRight As Variant) As String
'Worksheets("Sheet5").Cells(R1, 3) = AlphuSku(Worksheets("Sheet5").Cells(R1, 4), " BY ", ". ", "IS MADE OUT OF")
'Note: The spaces in the example above are important - false positives result without them!

Dim sTemp As String, aSku() As String
sTemp = UCase(myString)

sTemp = Replace(sTemp, sMid, "^")
sTemp = Replace(sTemp, sLeft, "^")
sTemp = Replace(sTemp, sRight, "^")

aSku = Split(sTemp, "^")
If UBound(aSku) >= 1 Then
sTemp = Replace(sTemp, aSku(1), "")
aSku = Split(sTemp, "^")
End If

If UBound(aSku) >= 2 Then AlphuSku = Trim(aSku(2))

'Test Value: '=AlphuSku(D429," BY ",". ","IS MADE OUT OF") 'row 429
End Function

Function udf_BaseMaterial(myStr As Variant) As String
'Example: aWs3(R3, i3Content) = udf_BaseMaterial(aWs3(R3, i3Content))

Dim sTemp As String
sTemp = myStr

myStr = Replace(myStr, "- ", "-")
myStr = Replace(myStr, "-", "(")
myStr = Replace(myStr, "%", "%)")
myStr = Replace(myStr, ";", " ")
udf_BaseMaterial = myStr
End Function

Function udf_CheckWs2_UniqueArr(ByRef myArr() As Variant, myTestStringUnique As Variant, myColCheckUnique As Long) As Boolean
'Example: [If udf_CheckWs2_UniqueArr(aWs2(), aTestVal1(R1, 1), iTestObjectCol1) = True Then]
'Use with: [iTestObjectCol1 = udf_ReturnArrayHeaderColumn(aWs3Headers, aTestCol1(R1, 1))] method
Dim iLoop As Long

'Reset to False prior to running test
udf_CheckWs2_UniqueArr = False

'Don't check if the string to test has a [Blank] value
If Trim(myTestStringUnique) = "" Then Exit Function

For iLoop = LBound(myArr) To UBound(myArr)
    'Each column in the array should be sorted with null values at the end of contiguous lists - once it hits the first blank, stop looking
    If Trim(myArr(iLoop, myColCheckUnique)) = "" Then Exit For

    If UCase(myArr(iLoop, myColCheckUnique)) = UCase(myTestStringUnique) Then
        udf_CheckWs2_UniqueArr = True
        Exit For
    End If
Next iLoop
End Function

Function udf_CheckWs3_SuperArray(ByRef myArr() As Variant, myTestString As Variant, myReplaceString As Variant, myCheckCol As Long, myReplaceCol As Long)
'Example[Call udf_CheckWs3_SuperArray(aWs3(), aTestVal1(R1, 1), aReplaceVal1(R1, 1), iTestObjectCol1, iChangeObjectCol1)]
'Note: Use UDF [udf_CheckWs2_UniqueArr] to check Unique list of values for quicker code execution when working with large data sets
Dim iLoop As Long

For iLoop = LBound(myArr) To UBound(myArr)
    If UCase(myArr(iLoop, myCheckCol)) = UCase(myTestString) Then

        'if [String match: myTestString] is found in the [Test column: myCheckCol], Change the value in the [Replace Column: myReplaceCol] to the [Corrected value: myReplaceString]
        myArr(iLoop, myReplaceCol) = udf_ReplaceString_Delete(myReplaceString)
'        Debug.Print "Replace " & myTestString & " on Ws3(Item_Info):" & Cells(iLoop, myCheckCol).Address; " // with Ws1(KravetRule) value " & myReplaceString & " using col "; Cells(1, myReplaceCol).Address

    End If
Next iLoop
End Function

Function udf_CheckWs3_SuperArray_TRIM(ByRef myArr() As Variant, myTestString As Variant, myReplaceString As Variant, myCheckCol As Long, myReplaceCol As Long, iRuleRow As Long, iRuleCol As Long, WsRule As Long, WsChange As Long, myStrTestColCondition As Variant)
'Use this array when a column change is conditional upon the value contained in another column. (Change [Type1] ONLY if the value in [Use] = "TRIM"
Dim myTrimCol As Long, iLoop As Long
'Example[Call udf_CheckWs3_SuperArray(aWs3(), aTestVal1(R1, 1), aReplaceVal1(R1, 1), iTestObjectCol1, iChangeObjectCol1)]
'Note: Use UDF [udf_CheckWs2_UniqueArr] to check Unique list of values for quicker code execution when working with large data sets

myTrimCol = myCheckCol
myCheckCol = myReplaceCol

For iLoop = LBound(myArr) To UBound(myArr)
    If UCase(myArr(iLoop, myCheckCol)) = UCase(myTestString) Then

    'Test to make sure the [Use] field = "TRIM"
    If UCase(myArr(iLoop, myTrimCol)) <> UCase(myStrTestColCondition) Then
        Exit Function 'split line temporary - during test only!
    End If

'probable insert here: If myCheckCol,row 1= "Use" then... (May need to put it into the unique array as well.

        'if [String match: myTestString] is found in the [Test column: myCheckCol], Change the value in the [Replace Column: myReplaceCol] to the [Corrected value: myReplaceString]
        myArr(iLoop, myReplaceCol) = udf_ReplaceString_Delete(myReplaceString)
'        Debug.Print "Replace " & myTestString & " on Ws3(Item_Info):" & Cells(iLoop, myCheckCol).Address; " // with Ws1(KravetRule) value " & myReplaceString & " using col "; Cells(1, myReplaceCol).Address
        'for test purpose only - to see which rules had matched values
        Worksheets(WsRule).Cells(iRuleRow, iRuleCol).Interior.ColorIndex = 6
        'Debug.Print "[" & Worksheets(WsChange).Name & "].[" & Cells(iLoop, myReplaceCol).Address & "], changed from [VALUE:" & Worksheets(WsChange).Cells(iLoop, myReplaceCol) & "] (--" & Worksheets(WsChange).Cells(1, myReplaceCol) & "--) to [VALUE:" & udf_ReplaceString_Delete(myReplaceString) & "] based on Rule:[" & Worksheets(WsRule).Name & "].[" & Cells(iRuleRow, iRuleCol).Address & "]"
        myIndex = myIndex + 1
        aActionsPerformed(myIndex, 1) = "[" & Worksheets(WsChange).Name & "].[" & Cells(iLoop, myReplaceCol).Address & "], changed from [VALUE:" & Worksheets(WsChange).Cells(iLoop, myReplaceCol) & "] (--" & Worksheets(WsChange).Cells(1, myReplaceCol) & "--) to [VALUE:" & udf_ReplaceString_Delete(myReplaceString) & "] based on Rule:[" & Worksheets(WsRule).Name & "].[" & Cells(iRuleRow, iRuleCol).Address & "]"

    End If
Next iLoop
End Function

Public Function CheckHeader(iMyText As String, iMyWs As Long, iMyRow As Long, iMyEndCol As Long) As Double
'----------------------------------------------------------------------------------------------------
'Defines Current Sheet then moves to desired sheet
'Loops through the columns in the defined Header Row checking for an exact match on defined String
'Returns a numeric value if String is found, 0 if not found.
'Selects the original tab that was active when Function was called
'----------------------------------------------------------------------------------------------------
'Example:(How to use function)
'If CheckHeader(Ws1, iHeader, iCe1, "Stripped") <> 0 Then iStripA = CheckHeader(Ws1, iHeader, iCe1, "Stripped")
'----------------------------------------------------------------------------------------------------
Dim iTempWorksheet As Long
iTempWorksheet = ActiveWorkbook.ActiveSheet.Index
Worksheets(iMyWs).Select

Dim iLoopCol As Long
CheckHeader = 0

For iLoopCol = 1 To iMyEndCol
    If UCase(Cells(iMyRow, iLoopCol)) = UCase(iMyText) Then
        CheckHeader = iLoopCol
        Exit For
    Else
    End If
Next iLoopCol
Worksheets(iTempWorksheet).Select
End Function

Function udf_CleanCollection(myStr1 As Variant, myStr2 As Variant) As String
'Example (Place in a loop): a3Collection(R3, 1) = UDF_CleanCollection(a3Collection(R3, 1), a3BookName(R3, 1))
Dim sTemp As String, aTempString As Variant

'--------------------------------------------------------------------------------------------------------------------------------------------------
'Skip processing the 1st string if it is blank (Set the result to the 2nd string and exit
If Trim(myStr1) = "" Then
udf_CleanCollection = Trim(myStr2): Exit Function
End If
'--------------------------------------------------------------------------------------------------------------------------------------------------

'--------------------------------------------------------------------------------------------------------------------------------------------------
'Process the 1st String
sTemp = myStr1

'================================================================
'Fix character issue (ampersand coming over as String instead of [&])
sTemp = Replace(sTemp, " & ", " & ", 1, , vbTextCompare)
'================================================================

'================================================================
'If the last char is Not a "I" (Roman Numeral:I, II, III), create split by inserting Delimiter (Note:No adjustment for "X" & "V")
If UCase(Right(sTemp, 1)) <> "I" Then sTemp = Replace(sTemp, "I ", "I^", 1, , vbTextCompare)
'================================================================

'================================================================
'Insert a delimiter at the end if the delimiter is not found:
If InStr(1, sTemp, "^", vbTextCompare) = 0 Then sTemp = sTemp & "^"
'================================================================

'================================================================
'Create a String(Array) to extract the "Clean" (left) string ONLY
aTempString = Split(sTemp, "^")
sTemp = aTempString(LBound(aTempString))
'================================================================

'================================================================
'Return results: Remove leading/trailing [Spaces]
udf_CleanCollection = Trim(sTemp)
'================================================================

'================================================================
'In case the final result returns a blank, change to 2nd String
If udf_CleanCollection = "" Then udf_CleanCollection = myStr2
'================================================================
'--------------------------------------------------------------------------------------------------------------------------------------------------
'Release memory
Erase aTempString
End Function

Function LeftDec(myString As Variant, myRow As Long) As Variant
Dim aSplitDecimal() As String

aSplitDecimal = Split(myString, ".")
LeftDec = aSplitDecimal(LBound(aSplitDecimal))
End Function

Function RightDec(myString As Variant, myRow As Long) As Variant
Dim aSplitDecimal() As String

aSplitDecimal = Split(myString, ".")
RightDec = aSplitDecimal(UBound(aSplitDecimal))
End Function

Function MidDec(myString As Variant, myRow As Long) As Variant
Dim aSplitDecimal() As String
MidDec = ""

aSplitDecimal = Split(myString, ".")
If UBound(aSplitDecimal) = 2 Then
    process
    MidDec = aSplitDecimal(1)
Else
    'skip without returning a value
    Exit Function
End If
MidDec = aSplitDecimal(UBound(aSplitDecimal))
End Function

Function FindAny(myString As Variant, myCheckString As Variant) As String
'HTML
myString = UCase(myString)
myCheckString = UCase(myCheckString)

Dim myStart As String, myEnd As String
Dim iStart As Long, iEnd As Long

FindAny = ""

myStart = myCheckString
myEnd = "<LI>"

    iStart = InStr(1, myString, myStart)
    If iStart > 0 Then iStart = iStart + Len(myStart)
    iEnd = InStr(iStart + 1, myString, myEnd)

If iEnd = 0 Then iEnd = Len(myString)

If iStart = 0 Or iEnd = 0 Then Exit Function
FindAny = Trim(Mid(myString, iStart, iEnd - iStart))

FindAny = Replace(FindAny, "</li><li><b class=", "")
FindAny = Replace(FindAny, "</B>", "")

FindAny = Replace(FindAny, "</LI>", "")
FindAny = Replace(FindAny, "</UL", "")

If Right(FindAny, 1) = "<" Then FindAny = Left(FindAny, Len(FindAny) - 1)
If Right(FindAny, 1) = ">" Then FindAny = Left(FindAny, Len(FindAny) - 1)
If Left(FindAny, 1) = "<" Then FindAny = Right(FindAny, Len(FindAny) - 1)
If Left(FindAny, 1) = ">" Then FindAny = Right(FindAny, Len(FindAny) - 1)
End Function

Function ExtractPart(myText As Variant, myDelimiter) As String
'2015
'----------------------------------------------------------
'Worksheets(Ws1).Cells(R1, 4) = ExtractPart(Worksheets(Ws1).Cells(R1, iColCheck), " ")
'----------------------------------------------------------

'----------------------------------------------------------
Dim iCount As Integer, aPosPart As Variant, sTemp As String, sLeft1 As String
'----------------------------------------------------------

'Check the first character - if it is a HTML Open/Close tag, don't proceed
sLeft1 = Left(myText, 1)
If sLeft1 = "<" Or sLeft1 = ">" Then Exit Function

'Convert to Ucase for coding ease during later analysis
myText = UCase(myText)

'Create a blank object to hold results
sTemp = ""

'Create an array to hold the "chunks" of data between the delimiter
aPosPart = Split(myText, myDelimiter)

'Loop through each "chunk" of strings and analyze to see if it fits the pattern of a part number
For iCount = 0 To UBound(aPosPart)

    'All part numbers must be at least 5 digits long
    If Len(aPosPart(iCount)) > 4 Then
        'assuming it is a potential PN...

        'Test to make sure there are Alpha & Numeric values within the Sub-String
        If AllAlpha(aPosPart(iCount)) = False Then

            'Replace smaller strings with larger strings
            If Len(aPosPart(iCount)) > Len(sTemp) Then

                'Note:Add more exclusions to this line as they are discovered
                If InStr(1, aPosPart(iCount), "%") > 0 Then
                'Old examples: 'If Left(aPosPart(iCount), 5) = "TSSOP" Or Left(aPosPart(iCount), 3) = "TO-" Or Left(aPosPart(iCount), 3) = "SOT" Then
                    'do nothing - - ignore
                Else
                    'Replace the Temp String with this value
                    'If InStr(1, aPosPart(iCount), "-") > 0 Then

                        If InStr(1, aPosPart(iCount), "117-2013") > 0 Or InStr(1, aPosPart(iCount), "866-516-0934") > 0 Then
                        'do nothing
                        Else
                            sTemp = aPosPart(iCount)
                        End If
                    'Else
                    'End If
                End If
            End If
        End If
    Else
        'assuming it is not a potential PN because it is 4 digits or less - ignore
    End If
Next iCount
If sTemp <> "" Then
    'Use the value found
    ExtractPart = sTemp
Else
    'Call the alternate method to extract Alpha values.
    ExtractPart = AlphuSku(myText, " BY ", ". ", "IS MADE OUT OF")
End If
End Function

Public Function FormatStandard(myTab As Long)
'-----------------------------------------------------------------------------------------
'Selects desired worksheet, applys formats and returns to current worksheet when finished
'Formatting Standards: Lock Headers, Apply Filters, Autofit, Remove WrapText
'-----------------------------------------------------------------------------------------
Dim iCurrentWs As Long
iCurrentWs = ActiveSheet.Index

'-------------------------------------------------------------------------
'Freeze Header, Fix Header Fields
    Sheets(myTab).Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
    Application.CutCopyMode = False
    Cells.Select
    Selection.AutoFilter
'-------------------------------------------------------------------------
'Autofit columns
    Cells.Select
    Cells.EntireColumn.AutoFit

    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Range("A2").Select
'-------------------------------------------------------------------------
Worksheets(iCurrentWs).Select
End Function

Function FracToDec(myString As Variant) As Variant
'Note: when it is a "Constant" that a single delimiter is present ([-] or [/]), you can use lbound(split) and ubound(split) to reference the left and right sides of the delimiter!!!

Dim bHasFraction As Boolean, bHasWholeNum As Boolean
Dim sWholeNum As String, sNumerator As String, sDenominator As String
Dim aSplitDash() As String, aSplitSlash() As String

'Reset the boolean results
bHasFraction = False: bHasWholeNum = False

'Remove the trailing ["] character
myString = Replace(myString, """", "")                                          'Example: [1-1/5"] becomes [1-1/5]
FracToDec = myString

'Test for characters that indicate a fraction/whole number is present in string
If InStr(1, myString, "/", vbTextCompare) <> 0 Then bHasFraction = True
If InStr(1, myString, "-", vbTextCompare) <> 0 Then bHasWholeNum = True

'Pre-Split (Isolate) the whole number if there is a [-] present
If bHasWholeNum = True Then
    aSplitDash = Split(myString, "-")
    sWholeNum = aSplitDash(LBound(aSplitDash))
End If
'---------------------------------------------------------------------------------
'Compile components of string and return function value

'Whole number only
If bHasWholeNum = False And bHasFraction = False Then
    FracToDec = myString

'Fraction only
ElseIf bHasWholeNum = False And bHasFraction = True Then

    'Split using the [/]
    aSplitSlash = Split(myString, "/")                                          'Splits [1/5]

    'take the value to the left of the [/]
    sNumerator = aSplitSlash(LBound(aSplitSlash))                                '[1/5] - grabs only [1]
    'take the value to the right of the [/]
    sDenominator = aSplitSlash(UBound(aSplitSlash))                              '[1/5] - grabs only [5]

        'Compile the calculate value
        FracToDec = (sNumerator / sDenominator)

'Whole number + fraction                                                         'Example: [1-1/5]
ElseIf bHasWholeNum = True And bHasFraction = True Then

    'Use the value to the right of the [-], then split that using the [/]        'Splits [1-1/5] - grabs only [1/5]
    aSplitSlash = Split(aSplitDash(UBound(aSplitDash)), "/")

    'take the value to the left of the [/]
    sNumerator = aSplitSlash(LBound(aSplitSlash))                                '[1/5] - grabs only [1]
    'take the value to the right of the [/]
    sDenominator = aSplitSlash(UBound(aSplitSlash))                              '[1/5] - grabs only [5]

        'Compile the calculate value
        FracToDec = sWholeNum & (sNumerator / sDenominator)

Else
    'should never get to this point...
End If
'---------------------------------------------------------------------------------

'---------------------------------------------------------------------------------
'Final formatting before returning results

    'remove the leading 0 from the resulting decimal format
    FracToDec = Replace(FracToDec, "0.", ".")

    'standardize the number format
    FracToDec = Format(FracToDec, "0.####")

    'truncate if the last digit is a [.]
    If Right(FracToDec, 1) = "." Then FracToDec = Left(FracToDec, Len(FracToDec) - 1)
'---------------------------------------------------------------------------------
End Function

Function udf_InchesWidthString(ByRef myArr() As Variant, myValue As Variant) As String
'Example: aWs3(R3, i3Width) = udf_InchesWidthString(aWs3(), aWs3(R3, i3Width))

'Function udf_InchesWidthString(myValue As Variant) As String ''This method used for testing as a worksheet function

Dim myNumber As Long, myInches As Double, myCenti As Double, sCat As String, sInch As String, sCM As String
myInches = Format(Val(myValue), "0.##")
myCenti = Format(myInches * 2.54, "0.##")

If myInches >= 0 And myInches < 9 Then
    sCat = "0-9 inches"

ElseIf myInches >= 10 And myInches < 19 Then
    sCat = "10-19 inches"

ElseIf myInches >= 20 And myInches < 29 Then
    sCat = "20-29 inches"

ElseIf myInches >= 30 And myInches < 39 Then
    sCat = "30-39 inches"

ElseIf myInches >= 40 And myInches < 49 Then
    sCat = "40-49 inches"

ElseIf myInches >= 50 And myInches < 59 Then
    sCat = "50-59 inches"

ElseIf myInches >= 60 And myInches < 69 Then
    sCat = "60-69 inches"

ElseIf myInches >= 70 And myInches < 79 Then
    sCat = "70-79 inches"

ElseIf myInches >= 80 And myInches < 89 Then
    sCat = "80-89 inches"

ElseIf myInches >= 90 And myInches < 99 Then
    sCat = "90-99 inches"

ElseIf myInches >= 100 And myInches < 149 Then
     sCat = "100-149 inches"

ElseIf myInches >= 150 Then
    sCat = "150 inches (+)"
Else
    sCat = ""
End If
sInch = ";": sCM = ";"

If myInches <> 0 Then sInch = myInches & " inches;"
If myCenti <> 0 Then sCM = "(" & myCenti & " cm);"

udf_InchesWidthString = sInch & sCM & sCat
End Function

Function udf_ConcatColor(myTestColor As Variant, myBadColor As Variant, myGoodColor As Variant, myDelim As Variant) As String
'---------------------------------------------------------------------------------------------------------------
'Example: udf_ConcatColor(A9,"GOLD","yellow","|")
'---------------------------------------------------------------------------------------------------------------
Dim aSplit As Variant, sTemp As String, iLoop As Long, iCount As Long, sConcat As String
'Take string [Beige|Gold|Yellow|Yellow], Change Gold(bad) to Yellow(Good), Then remove any dupe values by splitting into an array using [Pipes][|]
'Note: Newer version of fixing color when dealing with single column + delimiter - use [old_udf_ConcatColor] when dealing with multiple column values
'---------------------------------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------------------------------
'Set the Final Result(s) to nothing
sConcat = "": udf_ConcatColor = ""
'---------------------------------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------------------------------
'Fix the current value if necessary by replacing the bad value in the string with the desired value
sTemp = Replace(myTestColor, myBadColor, myGoodColor, 1, , vbTextCompare)
'---------------------------------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------------------------------
'Split the string into an array in order to loop through each value
aSplit = Split(sTemp, myDelim)

    'Test to see if the current chunk is already in the final string - add it along with a pipe if not.
    For iLoop = LBound(aSplit) To UBound(aSplit)
        If InStr(1, sConcat, aSplit(iLoop), vbTextCompare) = 0 Then sConcat = sConcat & aSplit(iLoop) & myDelim
    Next iLoop

    'Remove the trailing Delimiter
    If Right(sConcat, 1) = myDelim Then sConcat = Left(sConcat, Len(sConcat) - 1)

    'Load the results in the Function value
    udf_ConcatColor = sConcat
'---------------------------------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------------------------------
'Clean up the memory
Erase aSplit
'---------------------------------------------------------------------------------------------------------------
End Function

Function udf_ReturnArrayHeaderColumn(ByRef myArray() As Variant, myArrString As Variant) As Long
'------------------------------------------------------------------------
'Receives an array and a string to check
'Returns a numeric value corresponding the the Col location of the 'string match' in a [,2] type array
'------------------------------------------------------------------------
Dim sArrString As String
Dim iLoop As Long
udf_ReturnArrayHeaderColumn = 0

For iLoop = LBound(myArray, 2) To UBound(myArray, 2)
    If UCase(myArray(1, iLoop)) = UCase(myArrString) Then
        udf_ReturnArrayHeaderColumn = iLoop
        Exit For
    End If
Next iLoop
End Function

Public Function SingleSpace(myString As Variant) As String

Dim sChar As String, sTwo As String, sMyResult As String
Dim iChar As Long

sChar = "": sTwo = "": sMyResult = ""

If Len(myString) < 2 Then
    SingleSpace = Trim(myString)
    Exit Function
End If

For iChar = 1 To Len(myString)
    sChar = Mid(myString, iChar, 1)
    sTwo = Right(Left(myString, iChar), 2)
    If sTwo = " " Then
    Else
        sMyResult = sMyResult & sChar
    End If
Next iChar

SingleSpace = Trim(sMyResult)

End Function

Function udf_SortDelimitedString(myString As Variant, myDel As Variant, bProper As Boolean) As String
Dim aStringSort As Variant, iLoop As Long, iIndex As Long, iReorderIndex As Long, sTemp As String

If bProper = True Then udf_SortDelimitedString = StrConv(myString, vbProperCase)
If bProper = False Then udf_SortDelimitedString = StrConv(myString, vbLowerCase)

'Skip this process if the string is blank or the delimiter is not present
If myString = "" Then Exit Function
If InStr(1, myString, myDel, vbTextCompare) = 0 Then Exit Function

'Create an array for Splitting the string
aStringSort = Split(myString, myDel)

'Loop through each chunk of the Array
For iLoop = 0 To UBound(aStringSort)

'Create a numeric value for resorting
iReorderIndex = iLoop

    'Loop from the current loop through the highest index of the array
    For iIndex = iLoop + 1 To UBound(aStringSort)
        'If the Test(Apha value)String is closer to Z than any remaining values in the delimited string array (If this is the first alpha value, the iReorderIndex stays constant and does not change)
        If UCase(aStringSort(iReorderIndex)) > UCase(aStringSort(iIndex)) Then
            iReorderIndex = iIndex
        End If
    Next iIndex

    'Do nothing if the resort index and the current test loop are the same
    If iReorderIndex <> iLoop Then
        'Set the Temporary string that will move to the end of the sort order
        sTemp = aStringSort(iLoop)
        'Swap the values
        aStringSort(iLoop) = aStringSort(iReorderIndex) 'replace the current string with a lower sort string
        aStringSort(iReorderIndex) = sTemp              'replace the higher sort string with the current temp value

    End If

Next iLoop

'Clear the Temp string for a new usage
sTemp = StrConv(aStringSort(LBound(aStringSort)), vbProperCase)
If bProper = False Then sTemp = StrConv(aStringSort(LBound(aStringSort)), vbLowerCase)

For iLoop = LBound(aStringSort) + 1 To UBound(aStringSort)
    If bProper = True Then
        sTemp = sTemp & myDel & StrConv(aStringSort(iLoop), vbProperCase)
    Else
        sTemp = sTemp & myDel & StrConv(aStringSort(iLoop), vbLowerCase)
    End If
Next iLoop

udf_SortDelimitedString = sTemp
End Function

Function udf_MaxWordCount(myWs As Long, myFirstRow As Long, myLastRow As Long, myFirstCol As Long, myLastCol As Long) As Long
Dim R1 As Long, C1 As Long, iCount As Long, iTotalCount As Long, sTemp As String

iTotalCount = 0

For R1 = myFirstRow To myLastRow

    For C1 = myFirstCol To myLastCol
        sTemp = Worksheets(myWs).Cells(R1, C1)

        iCount = Len(sTemp) - Len(Replace(sTemp, " ", ""))
        iTotalCount = iTotalCount + iCount

    Next C1
Next R1

udf_MaxWordCount = iTotalCount
End Function

Function udf_RoundCorrectly(myText As Variant, myDel As Variant) As String
Dim sInchesString As String, sNewValue As String
Dim aMyWidth As Variant, aMyDecimal As Variant
Dim iDecimalCount As Long, iDecimal As Long, iWholeNum As Long, iRoundMarker As Long

'----------------------------------------------------------------------------------------------------------------------------
'Force the Function to return a value
udf_RoundCorrectly = myText
'----------------------------------------------------------------------------------------------------------------------------

'Turn the string into an array by splitting (usually determined by [space])
aMyWidth = Split(myText, myDel)

'Set the string to be reviewed and ROUNDED (Excel round does not round 00.5 correctly)
sInchesString = aMyWidth(LBound(aMyWidth))

'Test for the presence of a Decimal point - split results into whole#/decimal if found
iDecimalCount = InStr(1, sInchesString, ".", vbTextCompare)

    '-----------------------------------------------------------------------------------------------------------------------------
    'If no decimal, return whole number, otherwise-increase the whole number by one if the 1st digit of the decimal is 5 or higher
    If iDecimalCount <> 0 Then
    '-----------------------------------------------------------------------------------------------------------------------------
        '-------------------------------------------------------------------------------------------------------------------------
        'Decimal place confirmed - split into 1)Whole # 2)Decimal
        aMyDecimal = Split(sInchesString, ".")

        'Truncate string to fit data type if TOO LARGE
        If Len(aMyDecimal(UBound(aMyDecimal))) > 9 Then aMyDecimal(UBound(aMyDecimal)) = Left(aMyDecimal(UBound(aMyDecimal)), 9)
        If Len(aMyDecimal(LBound(aMyDecimal))) > 9 Then aMyDecimal(LBound(aMyDecimal)) = Left(aMyDecimal(LBound(aMyDecimal)), 9)

        iDecimal = aMyDecimal(UBound(aMyDecimal)) 'Decimal
        iWholeNum = aMyDecimal(LBound(aMyDecimal)) 'Whole #

        'First digit of the decimal
        iRoundMarker = Left(iDecimal, 1)

        'Return Converted value
        sNewValue = iWholeNum
        If iRoundMarker >= 5 Then sNewValue = iWholeNum + 1
        '-------------------------------------------------------------------------------------------------------------------------
    '-----------------------------------------------------------------------------------------------------------------------------
    Else
    '-----------------------------------------------------------------------------------------------------------------------------
        'No decimal found - return the original string and goes no further
        Exit Function                                                                 '(old method:sNewValue = Int(sInchesString))

    '-----------------------------------------------------------------------------------------------------------------------------
    End If
    '-----------------------------------------------------------------------------------------------------------------------------

'Insert the Converted value(Inches) into the rest of the string
If sNewValue <> "" Then udf_RoundCorrectly = Replace(myText, sInchesString, sNewValue, 1, , vbTextCompare)

'release memory
Erase aMyWidth: Erase aMyDecimal
End Function

Sub fixeed()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = ""

End Sub

Sub a1_Step1_ReduceSupplierList_To_UniqueValues_Pivot()
'Need to add code to remove "(blank)" and [Null] values

'Note: Tested these two methods also - very time intensive and not the best option - use the Pivot method
'Array: (10+ minutes) - loop through 1st array - dump in 2nd array if no match (---Only procesed 25 of 42 columns in test---)
'Bubble Sort: (1:45) - Only ran one column - if using this method for 42 columns, processing time could be over an hour

Dim C1 As Long, iCe1 As Long, Ws1 As Long
Dim myTime As Date

'==============================================================
'Start Timer
myTime = Now
'==============================================================

Worksheets(ActiveWorkbook.Worksheets.Count).Select
udf_InsertTabRename ("Pivot")

'==============================================================
'Clear out old data
Worksheets("SupplierUnique").Select
Cells.ClearContents 'put back after test
'==============================================================

'==============================================================
'Set variables
Ws1 = Worksheets("Item_Info").Index
Worksheets(Ws1).Select
iCe1 = Worksheets(Ws1).Cells(1, 1).End(xlToRight).Column
'==============================================================

'==============================================================
'Turn off processess so macro will run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'==============================================================

'==============================================================
'Loop through columns (Call Pivot Function)
For C1 = 1 To iCe1
DoEvents
    Application.StatusBar = "Processing Column " & C1 & " of " & iCe1
    Call udf_RunMyPivot(C1, Worksheets(Ws1).Name, "SupplierUnique")
Next C1
'==============================================================

'==============================================================
'Format sheet for visibility
Worksheets(Ws1).Select
    Cells.Select
    Selection.AutoFilter
    Cells.EntireColumn.AutoFit
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
    Range("A2").Select
'==============================================================

'==============================================================
'Remove the "Pivot" tab to avoid 'tab clutter'
Application.DisplayAlerts = False
Worksheets("Pivot").Delete
Application.DisplayAlerts = True
'==============================================================

'==============================================================
'Turn on processess when finished
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = ""
'==============================================================

'==============================================================
'Notify user that procedure finished and give time expended
MsgBox "Finished creating list of Unique values for each column." & Chr(13) & myTime & " / " & Now
'==============================================================
End Sub

Function udf_RunMyPivot(myCol As Long, sMySourceWB As String, sMyDestinationWB As String)
'---------------------------------------------------------------------------------------------
'Note: Uses relative cell references for end row/cell instead of dynamic (Newer) method
'Creates a temp tab that defines the pivot, then copies to a clean tab with results(Values only)
'Adds a column for Stripped data based on Header "Part"
'Creates prefered format of Pivot using dynamic code references (Not Hard Coded)
'Pivot Data Fields are Hard Coded (easily adjusted based on needs)
'---------------------------------------------------------------------------------------------
Dim myTime As Date
Dim sMyPivot As String
Dim R1 As Long, C1 As Long, iCe1 As Long, iRe1 As Long, iHeader As Long
Dim iRe2 As Long, aPivot() As Variant
Dim iStripCol As Long

Dim Ws1 As String
Dim Ws2 As Worksheet
Dim Ws3 As String

Dim PvtTbl As PivotTable
'---------------------------------------------------------------------------------------
    sMyPivot = "HiLo_Pivot"

    Ws1 = sMySourceWB
    Set Ws2 = Worksheets("Pivot")
    Ws3 = sMyDestinationWB

    iHeader = 1
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
'Item_Info: Set range
Sheets(Ws1).Select

Cells(1, 1).Select
Selection.End(xlToRight).Select
    iCe1 = Selection.Column

Cells(1048576, 1).Select
Selection.End(xlUp).Select
    iRe1 = Selection.Row
'---------------------------------------------------------------------------------------
Cells(iRe1, iCe1).Select
Range(Selection, Cells(1)).Select
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
'delete all existing Pivot Tables in the worksheet
'(in the TableRange1 property, page fields are excluded; to select the entire PivotTable report, including the page fields, use the TableRange2 property.)
For Each PvtTbl In Ws2.PivotTables
    PvtTbl.TableRange2.Clear
Next PvtTbl
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
'Create Pivot using range
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=Ws1 & "!R1C1:R" & iRe1 & "C" & iCe1, Version:=xlPivotTableVersion15).CreatePivotTable TableDestination:=Ws2.Range("A1"), TableName:=sMyPivot, DefaultVersion:=xlPivotTableVersion15
'    ActiveWorkbook.Sheets(Ws2).Tab.Color = 255
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
'Increase speed by turning off Calculate pivot while defining parameters (single calculation once finished instead of multiple calculations)
Ws2.Select
Set PvtTbl = Ws2.PivotTables(sMyPivot)
PvtTbl.ManualUpdate = True
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
'Set Layout of pivot table
                    'Old method
                    'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
                        'Turn off subtotals
                    '    With Ws2.PivotTables(sMyPivot)
                    '        For I = 1 To .PivotFields.Count
                    '            .PivotFields(I).Subtotals(1) = False
                    '        Next I
                    '    End With

                        'Turn off Grand Totals
                    '    With Ws2.PivotTables(sMyPivot)
                    '    'With ActiveSheet.PivotTables(sMyPivot)
                    '        .ColumnGrand = False
                    '        .RowGrand = False
                    '    End With
                    'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO

    'Set Tabular format and Repeat Item Labels
    Ws2.PivotTables(sMyPivot).ColumnGrand = False
    Ws2.PivotTables(sMyPivot).RowGrand = False
    Ws2.PivotTables(sMyPivot).PivotFields(1).Subtotals(1) = False
    Ws2.PivotTables(sMyPivot).RowAxisLayout xlTabularRow
    Ws2.PivotTables(sMyPivot).RepeatAllLabels xlRepeatLabels
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
'Set Rows
    With Ws2.PivotTables(sMyPivot).PivotFields(myCol)
        .Orientation = xlRowField
        .Position = 1
        '.PivotItems("0").Visible = False
    End With
'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
'Increase speed: Turn Pivot Calculate back on before copy/paste array data.
PvtTbl.ManualUpdate = False
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
'Remove "(blank") if it is the last record
'---------------------------------------------------------------------------------------
'Set End Row / Array for Ws2
Ws2.Select
iRe2 = Ws2.Cells(1048576, 1).End(xlUp).Row

'load array
aPivot = Range(Ws2.Cells(iHeader, 1), Ws2.Cells(iRe2, 1))

    '==============================================================
    'Remove the last record if the value is "(blank")
    If Ws2.Cells(iRe2, 1) = "(blank)" Then aPivot(UBound(aPivot), 1) = ""
    '==============================================================
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
'Dump an array on to (SupplierUnique)
Worksheets(Ws3).Select

Set Destination = Range(Worksheets(Ws3).Cells(iHeader, myCol).Address)
Destination.Resize(UBound(aPivot, 1), UBound(aPivot, 2)).Value = aPivot()

    '==============================================================
    'Delete cells(shift:=xlup) if [blank] [0] [.] [Space]
    For R1 = LBound(aPivot) + 1 To UBound(aPivot)
            If Worksheets(Ws3).Cells(R1, myCol) = "0" Or Worksheets(Ws3).Cells(R1, myCol) = "." Or Worksheets(Ws3).Cells(R1, myCol) = ".." Or Worksheets(Ws3).Cells(R1, myCol) = "..." Or Worksheets(Ws3).Cells(R1, myCol) = " " Then
                Range(Worksheets(Ws3).Cells(R1, myCol).Address).Delete Shift:=xlUp
                R1 = R1 - 1
            End If
    Next R1
'==============================================================
'---------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------
'Delete Pivot Table
'Application.DisplayAlerts = False
'Worksheets(Ws2).Delete
'Application.DisplayAlerts = True
'---------------------------------------------------------------------------------------

'Debug.Print "Fstart: Start=" & FStart & " / End= " & Now
'---------------------------------------------------------------------------------------
'Recover Memory
Erase aPivot
'---------------------------------------------------------------------------------------
End Function

Public Function udf_InsertTabRename(myNewName As String)
'----------------------------------------------------------------------------------------------------------
'Defines current tab
'Loops through all tabs in book, if a tab exists with the same name as the desired new tab, it deletes it.
'Adds a new tab to the end of the book, renames it using desired String(myNewName)
'Selects the original tab that was active when Function was called
'----------------------------------------------------------------------------------------------------------

Dim iCurrentWs As Long, iTabLoop As Long, sCurrentWs As String

If ActiveSheet.Name = myNewName Then Worksheets(ActiveWorkbook.Worksheets.Count - 1).Select
iCurrentWs = ActiveSheet.Index: sCurrentWs = ActiveSheet.Name

For iTabLoop = 1 To ActiveWorkbook.Worksheets.Count
    If Worksheets(iTabLoop).Name = myNewName Then
        Application.DisplayAlerts = False
        Worksheets(iTabLoop).Delete
        Application.DisplayAlerts = True
        Worksheets(sCurrentWs).Select
        Exit For
    End If
Next iTabLoop
'-------------------------------------------------------------------------
    'add new sheet: rename
    Sheets.Add After:=Worksheets(ActiveWorkbook.Worksheets.Count)
    ActiveSheet.Name = myNewName
'-------------------------------------------------------------------------

Worksheets(sCurrentWs).Select
End Function

Sub Import_TabDelimited_TextFile()
'================================================================================================
'Note: Used to create a clean import of a [Text] file that is [Tab] delimited
'The code assumes that there are no chr(13) and replaces chr(10) with chr(13) for Line Parsing
'================================================================================================
Dim Ws1 As Long, iCount As Long, sFile As Variant
Dim LineText As String, myTempString As String, aTemp As Variant
Dim aList() As Variant, Destination As Range

'================================================================================================
'Prompt user for file (Used for text files - NOT comma delimited files)
'================================================================================================
'sFile = Application.GetOpenFilename("CSV Files (*.csv),*.csv", , "Select CSV Data File")
sFile = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Select Text Data File")
    If sFile = False Then
        MsgBox "Error with selecting file - process is being aborted."
        Exit Sub
    End If
'================================================================================================

'================================================================================================
'Open the file to be processed (Concatenate each Line Input into a single string)
Open sFile For Input As #24

    '---------------------------------------------------------------------------------
    'Clear the existing data on the spreadsheet (Can also use InsertTabRename method)
    Ws1 = Worksheets("Test").Index
    Worksheets(Ws1).Select
    Cells.Clear
    '---------------------------------------------------------------------------------

    '---------------------------------------------------------------------------------
    'Loop through each line and concatenate strings into a single (Temp) string
    While Not EOF(24)
        Line Input #24, LineText
        myTempString = myTempString & LineText
    Wend
    '---------------------------------------------------------------------------------

    '---------------------------------------------------------------------------------
    'Replace all of the Chr(10) values with chr(13) so valid LineSplit can be performed
    '---------------------------------------------------------------------------------
    myTempString = Replace(myTempString, Chr(10), Chr(13), 1, , vbTextCompare)
    aTemp = Split(myTempString, Chr(13))
    '---------------------------------------------------------------------------------

Close #24
'================================================================================================

'================================================================================================
'Create an array and load the values using each line from the text file
aList = Range(Worksheets(Ws1).Cells(1, 1), Worksheets(Ws1).Cells(UBound(aTemp), 1))
    For iCount = LBound(aTemp) To UBound(aTemp) - 1
        aList(iCount + 1, 1) = aTemp(iCount)
    Next iCount
'================================================================================================

'================================================================================================
'Dump the results
Worksheets(Ws1).Select

Set Destination = Range(Worksheets(Ws1).Cells(1, 1).Address)
Destination.Resize(UBound(aList, 1), UBound(aList, 2)).Value = aList()
'================================================================================================

'================================================================================================
'Select Column A, Apply Text to Columns, then Apply standard formatting:
    Columns("A:A").Select
    '============================================================================================
    'Run Text To Columns
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False, TrailingMinusNumbers:=True
    '============================================================================================
    'Turn on filter
    Cells.Select
    Selection.AutoFilter
    '============================================================================================
    'Lock Header
    With ActiveWindow
        .SplitColumn = 0: .SplitRow = 1
    End With
    '============================================================================================
    'Freeze panes
    ActiveWindow.FreezePanes = True
    '============================================================================================
    'Visual: Fit columns to width
    Cells.EntireColumn.AutoFit
    Range("A2").Select
    '============================================================================================
'================================================================================================

'================================================================================================
'Notify user and release memory
MsgBox "Done"
Erase aList
'================================================================================================
End Sub

Function udf_UpdateArray(ByRef myArr() As Variant, iTempWs As Long, iDumpWs As Long, iDumpCol As Long)
'Example: Call UDF_UpdateArray(a3Collection, Ws99, Ws2, i2Collection)
Dim iLastWs As Long, Destination As Range, iRe2 As Long, myTempArr() As Variant

'==============================================================
'Memorize the starting Tab (So we can return to it when done)
iLastWs = ActiveSheet.Index
'==============================================================

'==============================================================
'Go to the Scratch Pad - clear old data
Worksheets(iTempWs).Select
Cells.Clear
'==============================================================

'==============================================================
'Dump the Updated values
Set Destination = Range(Worksheets(iTempWs).Cells(1, 1).Address)
Destination.Resize(UBound(myArr, 1), UBound(myArr, 2)).Value = myArr
'==============================================================

'==============================================================
'create a uniqe list
Worksheets(iTempWs).Columns(1).RemoveDuplicates Columns:=Array(1), Header:=xlYes
'==============================================================

'==============================================================
'Sort the list
Call udf_Sort_JLA_pal(iTempWs, 1)
'==============================================================

'==============================================================
'Reset the last row [ubound(Array)]
iRe2 = Worksheets(iTempWs).Cells(1048576, 1).End(xlUp).Row
'Erase myArr
'==============================================================

'==============================================================
'Load a temporary Array with updated values
myTempArr = Range(Worksheets(iTempWs).Cells(1, 1).Address, Worksheets(iTempWs).Cells(iRe2, 1).Address)
'==============================================================

'==============================================================
'Clear the column on the sheet the new array is going to Dump on
Worksheets(iDumpWs).Select
Columns(iDumpCol).Clear
'==============================================================

'==============================================================
'Dump the Updated values
Set Destination = Range(Worksheets(iDumpWs).Cells(1, iDumpCol).Address)
Destination.Resize(UBound(myTempArr, 1), UBound(myTempArr, 2)).Value = myTempArr
'==============================================================

'==============================================================
'Go back to the sheet that was selected before this procedure started
Worksheets(iLastWs).Select
'==============================================================

'==============================================================
'Clear memory
Erase myTempArr
'==============================================================
End Function

Function UDF_SortData(myWs As Long, myHeader As Long, myCol As Long, myEndCol As Long, myEndRow As Long)
'Example: Call UDF_SortData(Worksheets("Supplier").Index, 1, 6, 8, 29855)

'Note: When adding columns, increase the size of the range definition or else the new columns will not stay with correct line.
    ActiveWorkbook.Worksheets(myWs).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(myWs).Sort.SortFields.Add Key:=Range(Worksheets(myWs).Cells(myHeader + 1, myCol).Address, Worksheets(myWs).Cells(myEndRow, myCol).Address), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(myWs).Sort
        .SetRange Range(Worksheets(myWs).Cells(myHeader, 1).Address, Worksheets(myWs).Cells(myEndRow, myEndCol).Address)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Function

Sub udf_ImportCSVfile()
Dim i As Long, iNextRow As Long, Ws1 As Long, iCount As Long, sFile As Variant
Dim LineText As String, myTempString As String
Dim aList() As Variant


sFile = Application.GetOpenFilename("CSV Files (*.csv),*.csv", , "Select CSV Data File")
'sFile = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Select Text Data File")
    If sFile = False Then
        MsgBox "Error with selecting file - process is being aborted."
        Exit Sub
    End If

'================================================================================================
'Manually define/load variables
'sFile = "P:\Product Import Files\Kravet\Kravet Data feed rules\Kravet 031717.csv"
    i = 1
    iNextRow = 1

'================================================================================================

'================================================================================================
'Open the file to be processed (1 of 2: Gets a ubound count for array)
Open sFile For Input As #24

    '---------------------------------------------------------------------------------
    'Clear the existing data on the spreadsheet (Can also use InsertTabRename method)
    Ws1 = Worksheets("Test").Index
    Worksheets(Ws1).Select
    Cells.Clear
    '---------------------------------------------------------------------------------

    '---------------------------------------------------------------------------------
    'Loop through each line and create a uBound count
    While Not EOF(24)
        Line Input #24, LineText
        P = Split(Record, ",")
        iCount = iCount + 1
    Wend
    '---------------------------------------------------------------------------------

Close #24
'================================================================================================

'================================================================================================
'Open the file to be processed (2 of 2: Loads the data into array and dumps on spreadsheet)
Open sFile For Input As #24

'---------------------------------------------------------------------------------
'Create the array that results will be dropped into
aList = Range(Worksheets(Ws1).Cells(1, 1), Worksheets(Ws1).Cells(iCount, 1))
'---------------------------------------------------------------------------------

    '---------------------------------------------------------------------------------
    'Loop through each line: Concatenate multiple lines that don't contain valid SKU Prefixes ("PL-")
    '---------------------------------------------------------------------------------
    While Not EOF(24)
        Line Input #24, LineText

    '---------------------------------------------------------------------------------
    'Account for the header:
    '---------------------------------------------------------------------------------
        If i = 1 Then
            aList(iNextRow, 1) = LineText
            i = i + 1
    '---------------------------------------------------------------------------------
    'Decide if the next line is valid or if it should be concatenated:
    '---------------------------------------------------------------------------------
        Else
            P = Split(Record, ",")

            '-------------------------------------------------------------------------
            If i > 1 And InStr(1, LineText, "PL-", vbTextCompare) <> 0 Then
                'valid string: 'Start a new Array row, load the current value
                iNextRow = iNextRow + 1
                myTempString = LineText
            '-------------------------------------------------------------------------
            Else
                'Invalid string - does not begin with standard SKU ("PL-") - append to last string
                myTempString = aList(iNextRow, 1) & LineText
            '-------------------------------------------------------------------------
            End If

        '---------------------------------------------------------------------------------
        'Populate the array, clear the temp string and increment the line number
        '---------------------------------------------------------------------------------
        aList(iNextRow, 1) = myTempString
        myTempString = ""

        i = i + 1
        '---------------------------------------------------------------------------------
        End If
    '---------------------------------------------------------------------------------
    Wend

Close #24
'================================================================================================

'================================================================================================
'Dump the results
Worksheets(Ws1).Select

Set Destination = Range(Worksheets(Ws1).Cells(1, 1).Address)
Destination.Resize(UBound(aList, 1), UBound(aList, 2)).Value = aList()
'================================================================================================

'================================================================================================
'Select Column A, Apply Text to Columns, then Apply standard formatting:
    Columns("A:A").Select
    '============================================================================================
    'Run Text To Columns
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False, TrailingMinusNumbers:=True
    '============================================================================================
    'Turn on filter
    Cells.Select
    Selection.AutoFilter
    '============================================================================================
    'Lock Header
    With ActiveWindow
        .SplitColumn = 0: .SplitRow = 1
    End With
    '============================================================================================
    'Freeze panes
    ActiveWindow.FreezePanes = True
    '============================================================================================
    'Visual: Fit columns to width
    Cells.EntireColumn.AutoFit
    Range("A2").Select
    '============================================================================================
'================================================================================================

'================================================================================================
'Notify user and release memory
MsgBox "Done"
Erase aList
'================================================================================================
End Sub

Sub CreateUniqueList_BarryAllen()
Dim iCol As Long, Ws1 As Long, myTime As Date
myTime = Now

Ws1 = Worksheets("Test2").Index
iCol = 2

''======================================================================
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
''======================================================================

''======================================================================
'Remove the values that cause sorting issues ([0][.][..][...][***use correct code***]
udf_ReplaceRogues_JLA_pal (Ws1)
''======================================================================

''======================================================================
'Loop through the columns, reduce to unique values, then sort that column
For iCol = 1 To 42
'Debug.Print iCol & "^" & Now

    Worksheets(Ws1).Columns(iCol).RemoveDuplicates Columns:=Array(1), Header:=xlYes
    Call udf_Sort_JLA_pal(Ws1, iCol)
Next iCol
''======================================================================

''======================================================================
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = ""
''======================================================================
MsgBox "Start:" & myTime & " | End:" & Now
End Sub

Function udf_Sort_JLA_pal(myWs As Long, myCol As Long)
'Dynamic Sort - Pass Ws.index, Col Location (End Row is dynamic to Col object)

    Worksheets(myWs).Sort.SortFields.Clear
    Worksheets(myWs).Sort.SortFields.Add Key:=Range(Worksheets(myWs).Cells(2, myCol).Address, Worksheets(myWs).Cells(Worksheets(myWs).Cells(1048576, myCol).End(xlUp).Row, myCol).Address), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With Worksheets(myWs).Sort
        .SetRange Range(Worksheets(myWs).Cells(1, myCol).Address, Worksheets(myWs).Cells(Worksheets(myWs).Cells(1048576, myCol).End(xlUp).Row, myCol).Address)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Function

Function udf_ReplaceRogues_JLA_pal(myWs As Long)
    Worksheets(myWs).Cells.Replace What:="...", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Worksheets(myWs).Cells.Replace What:="..", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Worksheets(myWs).Cells.Replace What:=".", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Worksheets(myWs).Cells.Replace What:="***use correct code***", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Worksheets(myWs).Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Worksheets(myWs).Cells.Replace What:=" ", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Function

Sub TestFindMe()

Dim Ws1 As Long, myRange As Range, myMatch As Object

Dim sTest As String, sAddress As String

sTest = "allspic"

Ws1 = Worksheets("Sheet5").Index
Set myRange = Worksheets(Ws1).UsedRange

With myRange
    Set myMatch = .Find(sTest, LookIn:=xlValues)
    If Not myMatch Is Nothing Then
        'Setting this variable provides a starting stopping point - when it loop back around to this one it knows it has reached the first value
        sAddress = myMatch.Address

        Do
            'Debug.Print myMatch.Address & ":" & myMatch
            Set myMatch = .FindNext(myMatch)
        Loop While Not myMatch Is Nothing And myMatch.Address <> sAddress
    End If
End With

Set myMatch = Nothing
Set myRange = Nothing

End Sub

4/6/17: Updated UDF - Slightly faster by limiting loop to 10 iterations [0-9] if len(myString) > 9, [1 to len(myString)] if <10

Public Function udf_ContainsNum(myString As Variant) As Boolean
'---------------------------------------------------------------------------------
'Loops through each Char in string. If ANY Numeric values are found, sets to TRUE
'---------------------------------------------------------------------------------
Dim iLoop As Long

udf_ContainsNum = False
If myString = "" Then Exit Function

If Len(myString ) < 10 Then

'Fastest route is to test each character - less than 10 characters
    For iLoop = 1 To Len(myString)
        If Mid(myString, iLoop, 1) Like "[0-9]" Then
            udf_ContainsNum = True
            Exit Function
        End If
    Next iLoop
Else

'fastest route is to run an instr test for digits 0 - 9
    For iLoop = 0 To 9
        If InStr(1, myString, iLoop, vbTextCompare) <> 0 Then
            udf_ContainsNum = True
            Exit Function
        End If
    Next iLoop
End If
End Function

Sub LoadDictionaryWithUniqueWords_Barry()
'Tools>References   // 'Microsoft Scripting Runtime
'Use updated: udf_ContainsNum
Dim myTime As Date

Dim Ws1 As Long, R1 As Long, R2 As Long, iRe1 As Long, iCe1 As Long, aData() As Variant, iHeader1 As Long
Dim Ws2 As Long, iRe2 As Long, iCe2 As Long, aDump() As Variant, iHeader2 As Long
Dim iTestCol As Long, iArrUbound As Long
Dim aCell As Variant, sWord As String, iLoop As Long

Dim DictEng As New Scripting.Dictionary
DictEng.CompareMode = TextCompare
Dim DictSpan As New Scripting.Dictionary
DictSpan.CompareMode = TextCompare
Dim DictFrench As New Scripting.Dictionary
DictFrench.CompareMode = TextCompare

Application.StatusBar = "Working"
'============================================================================================================
'Set Standard objects (Some Hard Coded for testing, Some are variables-usual)
'============================================================================================================
Ws1 = Worksheets("Item_Info").Index
Ws2 = Worksheets("Test").Index
iHeader1 = 1: iHeader2 = 1

Worksheets(Ws1).Select
iCe1 = Worksheets(Ws1).Cells(1, 1).End(xlToRight).Column
iRe1 = Worksheets(Ws1).Cells(1048576, 1).End(xlUp).Row
iTestCol = 2
'============================================================================================================

Application.StatusBar = "Creating Arrays:"
'============================================================================================================
'Assign the arrays:
'============================================================================================================
Worksheets(Ws1).Select

'Range Array - Source Data
'Debug.Print Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address).Address
aData = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)

            'Known ubound settings: Not used YET
            'iArrUbound = udf_MaxWordCount(Ws1, iHeader1 + 1, iRe1, 1, iCe1)
            'ReDim aDump(1 To iArrUbound, 1 To 2)
'Debug.Print iArrUbound
'============================================================================================================

Application.StatusBar = "Loading English Dictionary"
myTime = Now
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Load DictEngionary with Unique Names (> 2char AND isNumeric = false (removing [dash] for better results)
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

'Loop through Range Array
For R1 = LBound(aData) To UBound(aData)
DoEvents

    '==========================================================================================================
    'String array that holds each CELL value
    aCell = Split(aData(R1, 1), " ")
    '==========================================================================================================
    '==========================================================================================================
    For iLoop = LBound(aCell) To UBound(aCell)
        For R2 = 1 To 1
            'Individual word to test/add
            sWord = aCell(iLoop)

            '==================================================================================================
            'early exits...

            'If String is actually a number, or is too short, if it is already ADDED to the dictionary, ignore it! (Also, if contains [Pipe])
            If DictEng.Exists(sWord) = True Then Exit For           'GAME CHANGER!
            If Len(sWord) < 3 Then Exit For
            If IsNumeric(Replace(sWord, "-", "", 1, , vbTextCompare)) = True Then Exit For
            If InStr(1, sWord, "|", vbTextCompare) <> 0 Then Exit For
            If udf_ContainsNum(sWord) = True Then Exit For
            '==================================================================================================

                'Load Valid Words
                If DictEng.Exists(sWord) = False Then DictEng.Add Key:=sWord, Item:=DictEng.Count + 1

            '==================================================================================================
        Next R2
    Next iLoop
    '==========================================================================================================
Next R1

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Debug.Print "Max Word Count=" & iArrUbound & " / English Dictionary Count=" & DictEng.Count & " || Start=" & myTime & " ... End=" & Now

'============================================================================================================
'Add Valid word restrictions and remove from DictEngionary:
'''For iLoop = DictEng.Count - 1 To 0 Step -1
DoEvents
'If Right(iLoop, 3) = "000" Then Application.StatusBar = iLoop & " of " & DictEng.Count & " || Start=" & myTime & " ... End=" & Now
'    If udf_ContainsNum(DictEng.Keys(iLoop)) = True Then
        'Debug.Print DictEng.Keys(iLoop) & " / " & DictEng.Items(iLoop)
'        DictEng.Remove DictEng.Keys(iLoop)
'    End If
'''Next iLoop
'============================================================================================================
'Test for English spelling - if misspelled, keep. If Correct, remove
'============================================================================================================
'Test for Spanish spelling - if Spanish is correct, remove from DictEng. and add to Spanish version
'============================================================================================================
'Test for French spelling - if French is correct, remove from DictEng. and add to French version
'============================================================================================================

''''Application.StatusBar = "Testing Loaded Dictionary Data"
''''myTime = Now
'''''============================================================================================================
'''''Test only
''''For iLoop = 0 To DictEng.Count - 1
''''DoEvents
''''If Right(iLoop, 3) = "000" Then Application.StatusBar = iLoop & " // " & DictEng.Count
''''    'Debug.Print DictEng.Keys(iLoop), DictEng.Items(iLoop)
''''Next iLoop
'''''============================================================================================================

'Show time expenditure...
Debug.Print " || Start=" & myTime & " ... End=" & Now

'-------------------------------------------------------------------
'test end-----------------------------------------------------------
Application.StatusBar = ""
Erase aData: Erase aDump: Set DictEng = Nothing: Set DictSpan = Nothing: Set DictFrench = Nothing
Exit Sub
'test end-----------------------------------------------------------
'-------------------------------------------------------------------

'dump results-------------------------------------------------------------------------
Worksheets(Ws2).Select
Cells.Clear
'==============================================================
'Dump the Updated values
Set Destination = Range(Worksheets(Ws2).Cells(1, 1).Address)
Destination.Resize(UBound(aData, 1), UBound(aData, 2)).Value = aData
'==============================================================
'dump results-------------------------------------------------------------------------

Erase aData: Erase aDump: Set DictEng = Nothing: Set DictSpan = Nothing: Set DictFrench = Nothing
End SubLoad the dictionary with All (Valid) words from a spreadsheet - as defined by iRe1/iCe1

Need the form that goes with this - Code checks list of ALL words on sheet - spell check. If misspelled in English, checks Spanish and creates a list of Spanish words spelled correctly, if it doesn't match correctly spelled English/Spanish, but matches French, creates a list of French (ok) words.
Sub SlowTestSpellCheck(myCheckWs As Long)
lblStatus = "": lblCounter = 0: lblMax = 0
Dim myTime As Date
'Note Hard coded header row: 1 - will never process Row 1
Dim R1 As Long, C1 As Long, iLoop As Long, iCount As Long, aCellString As Variant, iRe1 As Long, iCe1 As Long, iMaxWords As Long, i1Header1 As Long, i2ColUnique As Long
Dim myCellString As String, myWordString As String
Dim aUpdatedName() As Variant, aFixWords() As Variant
Dim i2DumpCol1 As Long, i2DumpCol2 As Long, i2NextRow As Long
Dim aUnique() As Variant
Dim Ws2 As Long, iRe2 As Long, iCe2 As Long
Dim iSingleColumn As Long, bTooLarge1Col As Boolean
Dim xLoop As Long
Dim sSpellWord As String
'--------------------------------------------------------------------------------------------------------------------------------------
'Release memory in case of early exit where memory was not released.
Erase aUpdatedName: Erase aFixWords: Erase aUnique
'--------------------------------------------------------------------------------------------------------------------------------------
Ws2 = Worksheets("tmpSortUnique").Index
iRe1 = Worksheets(myCheckWs).UsedRange.Rows.Count
iCe1 = Worksheets(myCheckWs).UsedRange.Columns.Count
'--------------------------------------------------------------------------------------------------------------------------------------
'Set Object Variables: Use Dynamic methods instead of literal once testing finished
i1Header1 = 1
i2DumpCol1 = 1: i2DumpCol2 = 2: i2NextRow = 0: i2ColUnique = i2DumpCol2 + 1
'--------------------------------------------------------------------------------------------------------------------------------------
'Set the range of cells to be reviewed: ARRAY
aUpdatedName = Range(Worksheets(myCheckWs).Cells(i1Header1 + 1, 1).Address, Worksheets(myCheckWs).Cells(iRe1, iCe1).Address)
'--------------------------------------------------------------------------------------------------------------------------------------
'Get the total # of words in the range (Used to create ubound(ARRAY))

'..................................................................................................................................................................................
'Assume that the word list is short enough to handle an array dump on a single tab
bTooLarge1Col = False
iMaxWords = udf_MaxWordCount(myCheckWs, i1Header1, iRe1, 1, iCe1) '(In this case, 1st/Last Col is the same - usually it would be 1 to iCe1)
'..................................................................................................................................................................................
If iMaxWords = 0 Then
    MsgBox "There are no values to review on this worksheet. Try again"
    Exit Sub
End If
'..................................................................................................................................................................................
'The total estimated number of words is larger than the max number of rows on a spreadsheet
If iMaxWords > 1048576 Then
    '..............................................................................................................................................................................
    'create a boolean marker to handle column address diferently if using a single column instead of a full cell range
    bTooLarge1Col = True
    '..............................................................................................................................................................................
    'Notify the user that we are changing the process for this situation - get input from user
    MsgBox "Too many words to review - choose a single column to review on sheet " & Worksheets(myCheckWs).Name
    Worksheets(myCheckWs).Select
    iSingleColumn = Application.InputBox(Prompt:="Which Column do you want to run a spell check on?", Title:="Specify Column by Clicking on ANY Cell within that Column", Default:=Cells(1, 1).Address, Type:=8).Column
    '..............................................................................................................................................................................
    'Reset the value of variables using the new information
    aUpdatedName = Range(Worksheets(myCheckWs).Cells(i1Header1 + 1, iSingleColumn).Address, Worksheets(myCheckWs).Cells(iRe1, iSingleColumn).Address)
    iMaxWords = udf_MaxWordCount(myCheckWs, i1Header1, iRe1, iSingleColumn, iSingleColumn)
    '..............................................................................................................................................................................
        'If information is still too much - tell user to quit trying
        If iMaxWords > 1048576 Then
            MsgBox "Still too large - did not run the desired spell check - try something else."
            Exit Sub
        End If
    '..............................................................................................................................................................................
End If
'..................................................................................................................................................................................
'--------------------------------------------------------------------------------------------------------------------------------------

'--------------------------------------------------------------------------------------------------------------------------------------
Worksheets(Ws2).Select
Cells.Clear
'Set the range where results will be dumped (Mispelled words): ARRAY
aFixWords = Range(Worksheets(Ws2).Cells(i1Header1 + 1, i2DumpCol1).Address, Worksheets(Ws2).Cells(iMaxWords, i2DumpCol2).Address)
'--------------------------------------------------------------------------------------------------------------------------------------

'--------------------------------------------------------------------------------------------------------------------------------------
'Loop through each cell of the array, then review each individual word
'--------------------------------------------------------------------------------------------------------------------------------------
                                                                                                    lblStatus = "Creating a list of words from " & Worksheets(myCheckWs).Name & "- Record: ": lblMax = UBound(aUpdatedName)

Worksheets(myCheckWs).Select
For R1 = LBound(aUpdatedName) To UBound(aUpdatedName)                                  'loop through the rows in the array
DoEvents

                                                                                                    If Right(R1, 1) = "0" Then lblCounter = R1
For C1 = LBound(aUpdatedName, 2) To UBound(aUpdatedName, 2)                           'loop through the columns in the array (Wrong - only does a single column)

        'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
        'Create the object that will refer to the correct column (Default: literal if reviewing the entire sheet / Column specific if only reviwing a single column)
        xLoop = C1                                              'Default value
        If bTooLarge1Col = True Then xLoop = iSingleColumn      'Column Specific - overwrite Default
        'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

    '===============================================================
    'create String object for the [CELL]
    myCellString = aUpdatedName(R1, C1) 'forgot to put the column object - was only pulling column 1 (4/3/17)
    '===============================================================
    'Split the cell String into an array using [Space] delimiter (Individual Words)
    aCellString = Split(myCellString, " ")
    '===============================================================

    '===============================================================
    'Review each individual word in te cell
    For iLoop = LBound(aCellString) To UBound(aCellString)

        'Create a String object for the [WORD]
        myWordString = aCellString(iLoop)

            'Load every word into the array
                i2NextRow = i2NextRow + 1
                aFixWords(i2NextRow, 1) = myWordString
                aFixWords(i2NextRow, 2) = Cells(R1 + 1, xLoop).Address
    Next iLoop
    '===============================================================
Next C1
Next R1
'--------------------------------------------------------------------------------------------------------------------------------------

'==============================================================
Worksheets(Ws2).Select
'dump array
Set Destination = Range(Worksheets(Ws2).Cells(i1Header1, i2DumpCol1).Address)
Destination.Resize(UBound(aFixWords, 1), UBound(aFixWords, 2)).Value = aFixWords
'==============================================================
'erase array, set the lower array value, then reload the array
Erase aFixWords
iRe2 = Worksheets(Ws2).Cells(1, i2DumpCol2).End(xlDown).Row '*(changed to i2DumpCol2 - i2DumpCol1 had blanks and list was truncated)
aFixWords = Range(Worksheets(Ws2).Cells(i1Header1, i2DumpCol1).Address, Worksheets(Ws2).Cells(iRe2, i2DumpCol2).Address)
'==============================================================

'--------------------------------------------------------------------------------------------------------------------------------------
'Create a new Array to hold the unique list of words
aUnique = Range(Worksheets(Ws2).Cells(LBound(aFixWords, 1), i2ColUnique).Address, Worksheets(Ws2).Cells(UBound(aFixWords, 1), i2ColUnique).Address)
'--------------------------------------------------------------------------------------------------------------------------------------
'==============================================================
'Load the array
For R1 = LBound(aFixWords) To UBound(aFixWords)

    '222222222222222222222222222222222222222222222222222222222222222222222222222222222      'Reduce list to managable
    'allow for early exit after each test
    For R2 = 1 To 1

        'Skip strings that don't need to be checked for Spelling
        If Len(aFixWords(R1, 1)) < 3 Then Exit For                                          'do not load [blank] or (small) strings
        If udf_ContainsNum(aFixWords(R1, 1)) = True Then Exit For                           'do not load numeric values
        If InStr(1, aFixWords(R1, 1), "|", vbTextCompare) <> 0 Then Exit For                'do not load values with [Pipes] (Usually colors [black|beige])

        'If it makes it this far, load the value into the array
        aUnique(R1, 1) = aFixWords(R1, 1)
    Next R2
    '222222222222222222222222222222222222222222222222222222222222222222222222222222222
Next R1

'==============================================================
'dump array
Set Destination = Range(Worksheets(Ws2).Cells(i1Header1, i2ColUnique).Address)
Destination.Resize(UBound(aUnique, 1), UBound(aUnique, 2)).Value = aUnique
'==============================================================
        '--------------------------------------------------------------------------------------------------------------------------------------
        '--------------------------------------------------------------------------------------------------------------------------------------
        'Remove the duplicate values from words list, Then sort the results (reload array)
        Worksheets(Ws2).Columns(i2ColUnique).RemoveDuplicates Columns:=Array(1), Header:=xlYes
        Call udf_Sort_JLA_pal(Ws2, i2ColUnique)
        '--------------------------------------------------------------------------------------------------------------------------------------
        '--------------------------------------------------------------------------------------------------------------------------------------
'==============================================================
'erase the array, set the last row, then reload it with the new sorted, unique values
Erase aUnique
iRe2 = Worksheets(Ws2).Cells(1048576, i2ColUnique).End(xlUp).Row
aUnique = Range(Worksheets(Ws2).Cells(LBound(aFixWords, 1), i2ColUnique).Address, Worksheets(Ws2).Cells(iRe2, i2ColUnique).Address)
'==============================================================

'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
lblStatus = "Creating a list of valid words to run spell check on - Record: ": lblMax = UBound(aUnique)
For R1 = LBound(aUnique) To UBound(aUnique)
DoEvents
                                                                                            If Right(R1, 2) = "00" Then lblCounter = R1
    'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
    'Only run spell check if there is a string long enough to be valid
    'Reset the spell check to English

    If aUnique(R1, 1) <> "" And Len(aUnique(R1, 1)) > 2 Then

    'Convert from Variant to String object
    sSpellWord = aUnique(R1, 1)
        'Early exit once correctly spelled word is identified.
        For R2 = 1 To 1

        'Reset the spell check to English
        Application.SpellingOptions.DictLang = msoLanguageIDEnglishUS
            'Remove Correctly spelled words from the Array '''(Test the english version first - using the hijacked method)
    '''        If SpellCheckString(aUnique(R1, 1)) = True Then
            If spellCheck(sSpellWord) = True Then
                aUnique(R1, 1) = ""
                Exit For
            Else
                'Test for correct spelling in other languages:
                Application.SpellingOptions.DictLang = msoLanguageIDSpanish
                If spellCheck(sSpellWord) = True Then
                    'Debug.Print "Yes-Spanish: " & sSpellWord
                    aUnique(R1, 1) = ""
                        lbBadWordsSpanish.AddItem sSpellWord 'myMatch.Address
                        'lbBadWordsSpanish.List(lbBadWordsSpanish.ListCount - 1, 1) = myMatch

                    Exit For
                Else
                    Application.SpellingOptions.DictLang = msoLanguageIDFrench
                    If spellCheck(sSpellWord) = True Then
                    'Debug.Print "Yes-French: " & sSpellWord
                        aUnique(R1, 1) = ""
                        lbBadWordsFrench.AddItem sSpellWord 'myMatch.Address
                        'lbBadWordsFrench.List(lbBadWordsFrench.ListCount - 1, 1) = myMatch
                        Exit For
                    Else
                    End If
                End If

            End If
        Next R2
    End If
    'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
Next R1

    '==============================================================
    'dump array
    Set Destination = Range(Worksheets(Ws2).Cells(i1Header1, i2ColUnique + 1).Address)
    Destination.Resize(UBound(aUnique, 1), UBound(aUnique, 2)).Value = aUnique
    '==============================================================
    '--------------------------------------------------------------------------------------------------------------------------------------
    'Remove the duplicate values from misspelled words, Then sort the results (reload array)
    Worksheets(Ws2).Columns(i2ColUnique + 1).RemoveDuplicates Columns:=Array(1), Header:=xlYes
    Call udf_Sort_JLA_pal(Ws2, i2ColUnique + 1)
    '==============================================================
    '==============================================================
    'erase the array, set the last row, then reload it with the new sorted, unique values
    Erase aUnique
    iRe2 = Worksheets(Ws2).Cells(1048576, i2ColUnique + 1).End(xlUp).Row
    aUnique = Range(Worksheets(Ws2).Cells(LBound(aFixWords, 1), i2ColUnique + 1).Address, Worksheets(Ws2).Cells(iRe2, i2ColUnique + 1).Address)
    '==============================================================
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
'--------------------------------------------------------------------------------------------------------------------------------------
lbBadWords.List = aUnique
lbWordsWithAddress.Clear
lbWordsWithAddress.ColumnCount = UBound(aFixWords, 2)
lbWordsWithAddress.List = aFixWords
'--------------------------------------------------------------------------------------------------------------------------------------

'Reset the forms Status Bar values
lblStatus = "": lblCounter = 0: lblMax = 0
'--------------------------------------------------------------------------------------------------------------------------------------
'Release memory
Erase aUpdatedName: Erase aFixWords: Erase aUnique
'--------------------------------------------------------------------------------------------------------------------------------------

'Reset the spell check back to English!
Application.SpellingOptions.DictLang = msoLanguageIDEnglishUS
End Sub