1) SupersonicMethod
Sub SupersonicMethod()
Dim Ws1 As Long, iRe1 As Long, iColA As Long, iHeader1 As Long, iCe1 As Long, aWs1() As Variant, iWs1ColPaste As Long
Dim Ws2 As Long, iRe2 As Long, iColB As Long, iHeader2 As Long, iCe2 As Long, aWs2() As Variant, iWs2ColCopy As Long
Dim Ws99 As Long
'HHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHH
'Hardcoded objects (For Illustration purposes)
Ws1 = Worksheets("Sheet1").Index: iRe1 = 431: iColA = 1: iHeader1 = 10: iCe1 = 5: iWs1ColPaste = 3 '(Paste is blank/dump col)
Ws2 = Worksheets("Sheet1").Index: iRe2 = 20077: iColB = 4: iHeader2 = 6: iCe2 = 5: iWs2ColCopy = 5
Ws99 = Worksheets("WsTemp").Index
'HHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHH
'==============================================================
'Load the entire sheet into an array (Sheet containing: MatchA)
Worksheets(Ws1).Select
aWs1 = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
'==============================================================
'==============================================================
'Load the entire sheet into an array (Sheet containing: MatchA)
Worksheets(Ws2).Select
aWs2 = Range(Worksheets(Ws2).Cells(1, 1).Address, Worksheets(Ws2).Cells(iRe2, iCe2).Address)
'==============================================================
'1) Create a blank tab
InsertTabOrClear ("WsTemp")
'2) Load the (37 Line, 5 Column) Array[a123ABC]
Create123ABC
'3) Load the 2 Comparison Data Sets 'Normally Match B to A (This is an alternate - Match A to B)
'Ws / Last Row / Col Match / Header / Blank Ws
'---(No Array "Pre-Load" required)---
Call LoadArrayMatchA(Ws1, iRe1, iColA, iHeader1, Ws99) 'Call LoadArrayMatchB(Ws1, iRe1, iColA, iHeader1, Ws99)
Call LoadArrayMatchB(Ws2, iRe2, iColB, iHeader2, Ws99) 'Call LoadArrayMatchA(Ws2, iRe2, iColB, iHeader2, Ws99)
'4) Load the Sub loops (First/Last Row + ConcatString) into the array[a123ABC]
'---(Uses Public Arrays created above)---
Call a123ABC_LoadRows(aMatchA, 1, 2, 3, 4) 'Call a123ABC_LoadRows(aMatchB, 1, 2, 3, 4)
Call a123ABC_LoadRows(aMatchB, 1, 5, 6, 7) 'Call a123ABC_LoadRows(aMatchA, 1, 5, 6, 7)
'5) Match Keys
'---(Mixed: Public Arrays + "Pre-Loaded" Arrays)---
Call MatchData_BtoA(aMatchA, aMatchB, aWs1, iWs1ColPaste, aWs2, iWs2ColCopy)
'Call MatchData_BtoA(aMatchB, aMatchA, aWs2, iWs2ColCopy, aWs1, iWs1ColPaste)
'6) Dump the results back on 1st Sheet
'==============================================================
'---("Pre-Loaded" Array)---
Set Destination = Range(Worksheets(Ws1).Cells(1, 1).Address) 'Set Destination = Range(Worksheets(Ws2).Cells(1, 1).Address)
Destination.Resize(UBound(aWs1, 1), UBound(aWs1, 2)).Value = aWs1 'Destination.Resize(UBound(aWs2, 1), UBound(aWs2, 2)).Value = aWs2
'(Note: Example only refreshed a SINGLE col of data in a array that contained the ENTIRE sheet)
'Alternate Method:
' 1: Create 1 Column Arrays for A)Array(Ws2:aCopyData) B)Array(Ws1:aPasteToBlank)
' 2: In step 5 replace: aWs1 with aCopyData and iWs1ColPaste with 1
' : aWs2 with aCopyData and iWs2ColCopy with 1
' 3: In Step 6, set the destination address as Row 1 of same column as aPasteToBlank
' Change aWs1 to aPasteToBlank
'==============================================================
'-----------------------------------------------------------------------------------------------------
Erase aWs1: Erase aWs2 'Erase Arrays created within this Sub
Erase a123ABC: Erase aMatchA: Erase aMatchB 'Erase [PUBLIC] Arrays created as a result of this Sub
'-----------------------------------------------------------------------------------------------------
End Sub
Dim Ws1 As Long, iRe1 As Long, iColA As Long, iHeader1 As Long, iCe1 As Long, aWs1() As Variant, iWs1ColPaste As Long
Dim Ws2 As Long, iRe2 As Long, iColB As Long, iHeader2 As Long, iCe2 As Long, aWs2() As Variant, iWs2ColCopy As Long
Dim Ws99 As Long
'HHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHH
'Hardcoded objects (For Illustration purposes)
Ws1 = Worksheets("Sheet1").Index: iRe1 = 431: iColA = 1: iHeader1 = 10: iCe1 = 5: iWs1ColPaste = 3 '(Paste is blank/dump col)
Ws2 = Worksheets("Sheet1").Index: iRe2 = 20077: iColB = 4: iHeader2 = 6: iCe2 = 5: iWs2ColCopy = 5
Ws99 = Worksheets("WsTemp").Index
'HHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHH
'==============================================================
'Load the entire sheet into an array (Sheet containing: MatchA)
Worksheets(Ws1).Select
aWs1 = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
'==============================================================
'==============================================================
'Load the entire sheet into an array (Sheet containing: MatchA)
Worksheets(Ws2).Select
aWs2 = Range(Worksheets(Ws2).Cells(1, 1).Address, Worksheets(Ws2).Cells(iRe2, iCe2).Address)
'==============================================================
'1) Create a blank tab
InsertTabOrClear ("WsTemp")
'2) Load the (37 Line, 5 Column) Array[a123ABC]
Create123ABC
'3) Load the 2 Comparison Data Sets 'Normally Match B to A (This is an alternate - Match A to B)
'Ws / Last Row / Col Match / Header / Blank Ws
'---(No Array "Pre-Load" required)---
Call LoadArrayMatchA(Ws1, iRe1, iColA, iHeader1, Ws99) 'Call LoadArrayMatchB(Ws1, iRe1, iColA, iHeader1, Ws99)
Call LoadArrayMatchB(Ws2, iRe2, iColB, iHeader2, Ws99) 'Call LoadArrayMatchA(Ws2, iRe2, iColB, iHeader2, Ws99)
'4) Load the Sub loops (First/Last Row + ConcatString) into the array[a123ABC]
'---(Uses Public Arrays created above)---
Call a123ABC_LoadRows(aMatchA, 1, 2, 3, 4) 'Call a123ABC_LoadRows(aMatchB, 1, 2, 3, 4)
Call a123ABC_LoadRows(aMatchB, 1, 5, 6, 7) 'Call a123ABC_LoadRows(aMatchA, 1, 5, 6, 7)
'5) Match Keys
'---(Mixed: Public Arrays + "Pre-Loaded" Arrays)---
Call MatchData_BtoA(aMatchA, aMatchB, aWs1, iWs1ColPaste, aWs2, iWs2ColCopy)
'Call MatchData_BtoA(aMatchB, aMatchA, aWs2, iWs2ColCopy, aWs1, iWs1ColPaste)
'6) Dump the results back on 1st Sheet
'==============================================================
'---("Pre-Loaded" Array)---
Set Destination = Range(Worksheets(Ws1).Cells(1, 1).Address) 'Set Destination = Range(Worksheets(Ws2).Cells(1, 1).Address)
Destination.Resize(UBound(aWs1, 1), UBound(aWs1, 2)).Value = aWs1 'Destination.Resize(UBound(aWs2, 1), UBound(aWs2, 2)).Value = aWs2
'(Note: Example only refreshed a SINGLE col of data in a array that contained the ENTIRE sheet)
'Alternate Method:
' 1: Create 1 Column Arrays for A)Array(Ws2:aCopyData) B)Array(Ws1:aPasteToBlank)
' 2: In step 5 replace: aWs1 with aCopyData and iWs1ColPaste with 1
' : aWs2 with aCopyData and iWs2ColCopy with 1
' 3: In Step 6, set the destination address as Row 1 of same column as aPasteToBlank
' Change aWs1 to aPasteToBlank
'==============================================================
'-----------------------------------------------------------------------------------------------------
Erase aWs1: Erase aWs2 'Erase Arrays created within this Sub
Erase a123ABC: Erase aMatchA: Erase aMatchB 'Erase [PUBLIC] Arrays created as a result of this Sub
'-----------------------------------------------------------------------------------------------------
End Sub
2) Create123ABC
Public a123ABC() As Variant
Function Create123ABC()
'[Col-1: #A][Col-2/5: 1st Match][Col-3/6: Last Match] [Col-4/7: Load ConcatenatedString][Col-8: Use to Remember Last "Found" location - use|--| a123ABC(37,4/7) |--|]
'Load a Public Array with ALL Numeric/Alpha Characters along with (Sub Loop) locations - first through last occurance of matching First char
'Note: Non AlphaNumeric characters will have varied results [Dashes end up within the Alpha] [Spaces get sorted to the end]
'Extra long loops may be created when non-AlphaNumeric characters are present
ReDim a123ABC(1 To 37, 1 To 8) As Variant
Dim R1 As Long, sAlpha As String
sAlpha = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ:"
For R1 = 1 To Len(sAlpha)
a123ABC(R1, 1) = Mid(sAlpha, R1, 1)
Next R1
End Function
Function Create123ABC()
'[Col-1: #A][Col-2/5: 1st Match][Col-3/6: Last Match] [Col-4/7: Load ConcatenatedString][Col-8: Use to Remember Last "Found" location - use|--| a123ABC(37,4/7) |--|]
'Load a Public Array with ALL Numeric/Alpha Characters along with (Sub Loop) locations - first through last occurance of matching First char
'Note: Non AlphaNumeric characters will have varied results [Dashes end up within the Alpha] [Spaces get sorted to the end]
'Extra long loops may be created when non-AlphaNumeric characters are present
ReDim a123ABC(1 To 37, 1 To 8) As Variant
Dim R1 As Long, sAlpha As String
sAlpha = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ:"
For R1 = 1 To Len(sAlpha)
a123ABC(R1, 1) = Mid(sAlpha, R1, 1)
Next R1
End Function
3) LoadArrayMatchA / LoadArrayMatchB
Public aMatchA() As Variant
Public aMatchB() As Variant
Function LoadArrayMatchA(myWs As Long, myEndRow As Long, myColMatch As Long, myHeader As Long, myBlankWS As Long)
'Loads a single column of data: ALWAYS starts on Row 1 (Loaded Array will eliminate any data in 1st row through the HeaderRow)
Dim aTempArr() As Variant, R1 As Long
'==============================================================
'Go to the desired sheet and load the column data into a temporary array
Worksheets(myWs).Select
aTempArr = Range(Worksheets(myWs).Cells(1, myColMatch).Address, Worksheets(myWs).Cells(myEndRow, myColMatch).Address)
'==============================================================
'Clear the temp sheet
udfReset99 (myBlankWS)
'==============================================================
'Create the blank array on the blank sheet
Worksheets(myBlankWS).Select
aMatchA = Range(Worksheets(myWs).Cells(1, 1).Address, Worksheets(myWs).Cells(myEndRow, 2).Address)
'==============================================================
'Fill the blank array with data (String + Row Location)
For R1 = LBound(aTempArr) To UBound(aTempArr)
If R1 > myHeader Then
aMatchA(R1, 1) = aTempArr(R1, 1)
aMatchA(R1, 2) = R1
End If
Next R1
'==============================================================
'==============================================================
'Dump the Array
Set Destination = Range(Worksheets(myBlankWS).Cells(1, 1).Address)
Destination.Resize(UBound(aMatchA, 1), UBound(aMatchA, 2)).Value = aMatchA
'==============================================================
'==============================================================
'Sort the Array
Call udf_Sort_FullSheet(myBlankWS, 1, myEndRow, 2, False)
'==============================================================
'Clear the Array
Erase aMatchA
'adjust for new end row (col A - end up)
myEndRow = Worksheets(myBlankWS).Cells(1048576, 1).End(xlUp).Row
'==============================================================
'ReLoad the Array with: 1)String 2)Original Row Location
aMatchA = Range(Worksheets(myBlankWS).Cells(1, 1).Address, Worksheets(myBlankWS).Cells(myEndRow, 2).Address)
'==============================================================
Worksheets(myWs).Select
Erase aTempArr
End Function
Function LoadArrayMatchB(myWs As Long, myEndRow As Long, myColMatch As Long, myHeader As Long, myBlankWS As Long)
'Loads a single column of data: ALWAYS starts on Row 1 (Loaded Array will eliminate any data in 1st row through the HeaderRow)
Dim aTempArr() As Variant, R1 As Long
'==============================================================
'Go to the desired sheet and load the column data into a temporary array
Worksheets(myWs).Select
aTempArr = Range(Worksheets(myWs).Cells(1, myColMatch).Address, Worksheets(myWs).Cells(myEndRow, myColMatch).Address)
'==============================================================
'Clear the temp sheet
udfReset99 (myBlankWS)
'==============================================================
'Create the blank array on the blank sheet
Worksheets(myBlankWS).Select
aMatchB = Range(Worksheets(myWs).Cells(1, 1).Address, Worksheets(myWs).Cells(myEndRow, 2).Address)
'==============================================================
'Fill the blank array with data (String + Row Location)
For R1 = LBound(aTempArr) To UBound(aTempArr)
If R1 > myHeader Then
aMatchB(R1, 1) = aTempArr(R1, 1)
aMatchB(R1, 2) = R1
End If
Next R1
'==============================================================
'==============================================================
'Dump the Array
Set Destination = Range(Worksheets(myBlankWS).Cells(1, 1).Address)
Destination.Resize(UBound(aMatchB, 1), UBound(aMatchB, 2)).Value = aMatchB
'==============================================================
'==============================================================
'Sort the Array
Call udf_Sort_FullSheet(myBlankWS, 1, myEndRow, 2, False)
'==============================================================
'Clear the Array
Erase aMatchB
'adjust for new end row (col A - end up)
myEndRow = Worksheets(myBlankWS).Cells(1048576, 1).End(xlUp).Row
'==============================================================
'ReLoad the Array with: 1)String 2)Original Row Location
aMatchB = Range(Worksheets(myBlankWS).Cells(1, 1).Address, Worksheets(myBlankWS).Cells(myEndRow, 2).Address)
'==============================================================
Worksheets(myWs).Select
Erase aTempArr
End Function
Public aMatchB() As Variant
Function LoadArrayMatchA(myWs As Long, myEndRow As Long, myColMatch As Long, myHeader As Long, myBlankWS As Long)
'Loads a single column of data: ALWAYS starts on Row 1 (Loaded Array will eliminate any data in 1st row through the HeaderRow)
Dim aTempArr() As Variant, R1 As Long
'==============================================================
'Go to the desired sheet and load the column data into a temporary array
Worksheets(myWs).Select
aTempArr = Range(Worksheets(myWs).Cells(1, myColMatch).Address, Worksheets(myWs).Cells(myEndRow, myColMatch).Address)
'==============================================================
'Clear the temp sheet
udfReset99 (myBlankWS)
'==============================================================
'Create the blank array on the blank sheet
Worksheets(myBlankWS).Select
aMatchA = Range(Worksheets(myWs).Cells(1, 1).Address, Worksheets(myWs).Cells(myEndRow, 2).Address)
'==============================================================
'Fill the blank array with data (String + Row Location)
For R1 = LBound(aTempArr) To UBound(aTempArr)
If R1 > myHeader Then
aMatchA(R1, 1) = aTempArr(R1, 1)
aMatchA(R1, 2) = R1
End If
Next R1
'==============================================================
'==============================================================
'Dump the Array
Set Destination = Range(Worksheets(myBlankWS).Cells(1, 1).Address)
Destination.Resize(UBound(aMatchA, 1), UBound(aMatchA, 2)).Value = aMatchA
'==============================================================
'==============================================================
'Sort the Array
Call udf_Sort_FullSheet(myBlankWS, 1, myEndRow, 2, False)
'==============================================================
'Clear the Array
Erase aMatchA
'adjust for new end row (col A - end up)
myEndRow = Worksheets(myBlankWS).Cells(1048576, 1).End(xlUp).Row
'==============================================================
'ReLoad the Array with: 1)String 2)Original Row Location
aMatchA = Range(Worksheets(myBlankWS).Cells(1, 1).Address, Worksheets(myBlankWS).Cells(myEndRow, 2).Address)
'==============================================================
Worksheets(myWs).Select
Erase aTempArr
End Function
Function LoadArrayMatchB(myWs As Long, myEndRow As Long, myColMatch As Long, myHeader As Long, myBlankWS As Long)
'Loads a single column of data: ALWAYS starts on Row 1 (Loaded Array will eliminate any data in 1st row through the HeaderRow)
Dim aTempArr() As Variant, R1 As Long
'==============================================================
'Go to the desired sheet and load the column data into a temporary array
Worksheets(myWs).Select
aTempArr = Range(Worksheets(myWs).Cells(1, myColMatch).Address, Worksheets(myWs).Cells(myEndRow, myColMatch).Address)
'==============================================================
'Clear the temp sheet
udfReset99 (myBlankWS)
'==============================================================
'Create the blank array on the blank sheet
Worksheets(myBlankWS).Select
aMatchB = Range(Worksheets(myWs).Cells(1, 1).Address, Worksheets(myWs).Cells(myEndRow, 2).Address)
'==============================================================
'Fill the blank array with data (String + Row Location)
For R1 = LBound(aTempArr) To UBound(aTempArr)
If R1 > myHeader Then
aMatchB(R1, 1) = aTempArr(R1, 1)
aMatchB(R1, 2) = R1
End If
Next R1
'==============================================================
'==============================================================
'Dump the Array
Set Destination = Range(Worksheets(myBlankWS).Cells(1, 1).Address)
Destination.Resize(UBound(aMatchB, 1), UBound(aMatchB, 2)).Value = aMatchB
'==============================================================
'==============================================================
'Sort the Array
Call udf_Sort_FullSheet(myBlankWS, 1, myEndRow, 2, False)
'==============================================================
'Clear the Array
Erase aMatchB
'adjust for new end row (col A - end up)
myEndRow = Worksheets(myBlankWS).Cells(1048576, 1).End(xlUp).Row
'==============================================================
'ReLoad the Array with: 1)String 2)Original Row Location
aMatchB = Range(Worksheets(myBlankWS).Cells(1, 1).Address, Worksheets(myBlankWS).Cells(myEndRow, 2).Address)
'==============================================================
Worksheets(myWs).Select
Erase aTempArr
End Function
4) a123ABC_LoadRows
Function a123ABC_LoadRows(ByRef myArr() As Variant, myCol As Long, myColFirstRow As Long, myColLastRow As Long, myColStringConcat As Long)
'******************************************************************************************************************************************
'Use this to load the Rows for the two Public Arrays [aMatchA][aMatchB]
'******************************************************************************************************************************************
'If loading [aMatchA]: myColFirstRow = 2 / myColLastRow =3 / myColStringConcat = 4
'If loading [aMatchB]: myColFirstRow = 5 / myColLastRow =6 / myColStringConcat = 7
'******************************************************************************************************************************************
Dim Ws1 As Long, sString As String, sCheck As String, R1 As Long, iRe1 As Long, iMatchColA As Long, iAscii As Long, bAlpha As Boolean
Dim aData() As Variant
Dim sFirstDigit As String
Dim bNumeric As Boolean
'=====================================================================================================
'Loop through the Array to review
For R1 = LBound(myArr) To UBound(myArr)
DoEvents
'Reset the booleans to prevent false positives
bNumeric = False: bAlpha = False
'Load the first digit into an Object, then use the Boolean to separate into Alpha/Numeric handling
sFirstDigit = Left(Trim(UCase(myArr(R1, 1))), 1)
bNumeric = IsNumeric(sFirstDigit)
'Skip this loop if there is no value to test
If sFirstDigit = Empty Then GoTo BlankValue
'Load the Ascii Value into an object, then use the Booleand separate into Alpha/Numeric handling
iAscii = Asc(sFirstDigit)
If iAscii >= 65 And iAscii <= 90 Then bAlpha = True
'AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
'Handle Numeric Characters 'Note: Loading (R1) - the row # of The Sorted Array, not the Original Array Row
If bNumeric = True Then
'Set the first matching row (If not set yet), then set the Last matching Row (If 1st Row set already)
If a123ABC(iAscii - 47, myColFirstRow) = "" Then a123ABC(iAscii - 47, myColFirstRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(iAscii - 47, myColFirstRow) <> "" Then a123ABC(iAscii - 47, myColLastRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(iAscii - 47, myColFirstRow) <> "" Then a123ABC(iAscii - 47, myColStringConcat) = a123ABC(iAscii - 47, myColStringConcat) & myArr(R1, 1) & "^"
'Handle Alpha Characters
ElseIf bAlpha = True Then
'Set the first matching row (If not set yet), then set the Last matching Row (If 1st Row set already)
If a123ABC(iAscii - 54, myColFirstRow) = "" Then a123ABC(iAscii - 54, myColFirstRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(iAscii - 54, myColFirstRow) <> "" Then a123ABC(iAscii - 54, myColLastRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(iAscii - 54, myColFirstRow) <> "" Then a123ABC(iAscii - 54, myColStringConcat) = a123ABC(iAscii - 54, myColStringConcat) & myArr(R1, 1) & "^"
'Handle ALL other Characters
Else
'Set the first matching row (If not set yet), then set the Last matching Row (If 1st Row set already)
If a123ABC(37, myColFirstRow) = "" Then a123ABC(37, myColFirstRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(37, myColFirstRow) <> "" Then a123ABC(37, myColLastRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(37, myColFirstRow) <> "" Then a123ABC(37, myColStringConcat) = a123ABC(37, myColStringConcat) & myArr(R1, 1) & "^"
End If
'AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
'No Value to check (Skip loop)
BlankValue:
Next R1
'============================================================================================================
End Function
'******************************************************************************************************************************************
'Use this to load the Rows for the two Public Arrays [aMatchA][aMatchB]
'******************************************************************************************************************************************
'If loading [aMatchA]: myColFirstRow = 2 / myColLastRow =3 / myColStringConcat = 4
'If loading [aMatchB]: myColFirstRow = 5 / myColLastRow =6 / myColStringConcat = 7
'******************************************************************************************************************************************
Dim Ws1 As Long, sString As String, sCheck As String, R1 As Long, iRe1 As Long, iMatchColA As Long, iAscii As Long, bAlpha As Boolean
Dim aData() As Variant
Dim sFirstDigit As String
Dim bNumeric As Boolean
'=====================================================================================================
'Loop through the Array to review
For R1 = LBound(myArr) To UBound(myArr)
DoEvents
'Reset the booleans to prevent false positives
bNumeric = False: bAlpha = False
'Load the first digit into an Object, then use the Boolean to separate into Alpha/Numeric handling
sFirstDigit = Left(Trim(UCase(myArr(R1, 1))), 1)
bNumeric = IsNumeric(sFirstDigit)
'Skip this loop if there is no value to test
If sFirstDigit = Empty Then GoTo BlankValue
'Load the Ascii Value into an object, then use the Booleand separate into Alpha/Numeric handling
iAscii = Asc(sFirstDigit)
If iAscii >= 65 And iAscii <= 90 Then bAlpha = True
'AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
'Handle Numeric Characters 'Note: Loading (R1) - the row # of The Sorted Array, not the Original Array Row
If bNumeric = True Then
'Set the first matching row (If not set yet), then set the Last matching Row (If 1st Row set already)
If a123ABC(iAscii - 47, myColFirstRow) = "" Then a123ABC(iAscii - 47, myColFirstRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(iAscii - 47, myColFirstRow) <> "" Then a123ABC(iAscii - 47, myColLastRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(iAscii - 47, myColFirstRow) <> "" Then a123ABC(iAscii - 47, myColStringConcat) = a123ABC(iAscii - 47, myColStringConcat) & myArr(R1, 1) & "^"
'Handle Alpha Characters
ElseIf bAlpha = True Then
'Set the first matching row (If not set yet), then set the Last matching Row (If 1st Row set already)
If a123ABC(iAscii - 54, myColFirstRow) = "" Then a123ABC(iAscii - 54, myColFirstRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(iAscii - 54, myColFirstRow) <> "" Then a123ABC(iAscii - 54, myColLastRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(iAscii - 54, myColFirstRow) <> "" Then a123ABC(iAscii - 54, myColStringConcat) = a123ABC(iAscii - 54, myColStringConcat) & myArr(R1, 1) & "^"
'Handle ALL other Characters
Else
'Set the first matching row (If not set yet), then set the Last matching Row (If 1st Row set already)
If a123ABC(37, myColFirstRow) = "" Then a123ABC(37, myColFirstRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(37, myColFirstRow) <> "" Then a123ABC(37, myColLastRow) = R1 '[Original:myArr(R1, 2)]
If a123ABC(37, myColFirstRow) <> "" Then a123ABC(37, myColStringConcat) = a123ABC(37, myColStringConcat) & myArr(R1, 1) & "^"
End If
'AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
'No Value to check (Skip loop)
BlankValue:
Next R1
'============================================================================================================
End Function
5) MatchData_BtoA
Function MatchData_BtoA(ByRef arrMatchA() As Variant, ByRef arrMatchB() As Variant, ByRef myWs1() As Variant, myWs1ColPaste As Long, ByRef myWs2() As Variant, myWs2ColCopy As Long)
Dim sChar As String, iAscii As Long, bNumeric As Boolean, bAlpha As Boolean, iStart As Long, iEnd As Long, sTemp As String, iRemember As Long
''MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
For R1 = LBound(arrMatchA) To UBound(arrMatchA)
Application.StatusBar = "Processing Record " & R1 & " of " & UBound(arrMatchA)
DoEvents
'Set the String (From Ws1/A)
sMatch1 = UCase(arrMatchA(R1, 1))
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
bNumeric = False: bAlpha = False: iStart = 0: iEnd = 0
'Load the first digit into an Object, then use the Boolean to separate into Alpha/Numeric handling
sChar = Left(Trim(UCase(arrMatchA(R1, 1))), 1)
'Skip this loop if there is no value to test
If sChar = Empty Then GoTo BlankValue
'Create objects used for reviewing the First Character
bNumeric = IsNumeric(sChar)
iAscii = Asc(sChar)
If iAscii >= 65 And iAscii <= 90 Then bAlpha = True
'KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK
'BarryAllen 2.0 Test & React
'........................................................................................
'Handle Numeric
'........................................................................................
If bNumeric = True Then
'Check Array that holds #A - if First Row is present (Col 5), Run 2nd test
If Chr(iAscii) = a123ABC(iAscii - 47, 1) And a123ABC(iAscii - 47, 5) <> "" Then
'Check to see if the string is in the Array[#A]
If InStr(1, a123ABC(iAscii - 47, 7), arrMatchA(R1, 1), vbTextCompare) <> 0 Then
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'Use the First/Last Row defined in the Array[#A] to execute a loop
For R2 = a123ABC(iAscii - 47, 5) To a123ABC(iAscii - 47, 6)
'Set the String object used for matching
sTemp = UCase(arrMatchB(R2, 1))
If sMatch1 = sTemp Then
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'found a match - Load results 'myWs1(R1, 1) = arrCopy(R2, 1)
myWs1(arrMatchA(R1, 2), myWs1ColPaste) = myWs2(arrMatchB(R2, 2), myWs2ColCopy)
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
End If
Next R2
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
End If
End If
'........................................................................................
'........................................................................................
'Handle Alpha
'........................................................................................
ElseIf bAlpha = True Then
'Check Array that holds #A - if First Row is present (Col 5), Run 2nd test
If Chr(iAscii) = a123ABC(iAscii - 54, 1) And a123ABC(iAscii - 54, 5) <> "" Then
'Check to see if the string is in the Array[#A]
If InStr(1, a123ABC(iAscii - 54, 7), arrMatchA(R1, 1), vbTextCompare) <> 0 Then
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'Use the First/Last Row defined in the Array[#A] to execute a loop
For R2 = a123ABC(iAscii - 54, 5) To a123ABC(iAscii - 54, 6)
'Set the String object used for matching
sTemp = UCase(arrMatchB(R2, 1))
If sMatch1 = sTemp Then
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'found a match - Load results 'myWs1(R1, 1) = arrCopy(R2, 1)
myWs1(arrMatchA(R1, 2), myWs1ColPaste) = myWs2(arrMatchB(R2, 2), myWs2ColCopy)
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
End If
Next R2
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
End If
End If
'........................................................................................
'........................................................................................
'Handle everything else [~!@#$%^&*()_+`-={}|[]\:";'<>?,./]
'........................................................................................
Else
'Check Array that holds #A - if First Row is present (Col 5), Run 2nd test
If a123ABC(37, 5) <> "" Then
'Check to see if the string is in the Array[#A]
If InStr(1, a123ABC(37, 7), arrMatchA(R1, 1), vbTextCompare) <> 0 Then
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'Use the First/Last Row defined in the Array[#A] to execute a loop
For R2 = a123ABC(37, 5) To a123ABC(37, 6)
'Set the String object used for matching
sTemp = UCase(arrMatchB(R2, 1))
If sMatch1 = sTemp Then
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'found a match - Load results 'myWs1(R1, 1) = arrCopy(R2, 1)
myWs1(arrMatchA(R1, 2), myWs1ColPaste) = myWs2(arrMatchB(R2, 2), myWs2ColCopy)
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
End If
Next R2
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
End If
End If
End If
'........................................................................................
'KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'No Value to check (Skip loop)
BlankValue:
Next R1
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
'For R1 = LBound(a123ABC) To UBound(a123ABC)
' Debug.Print a123ABC(R1, 1) & " . " & a123ABC(R1, 2) & " . " & a123ABC(R1, 3) & " . " & a123ABC(R1, 4) & " . " & a123ABC(R1, 5)
'Next R1
Application.StatusBar = ""
End Function
Dim sChar As String, iAscii As Long, bNumeric As Boolean, bAlpha As Boolean, iStart As Long, iEnd As Long, sTemp As String, iRemember As Long
''MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
For R1 = LBound(arrMatchA) To UBound(arrMatchA)
Application.StatusBar = "Processing Record " & R1 & " of " & UBound(arrMatchA)
DoEvents
'Set the String (From Ws1/A)
sMatch1 = UCase(arrMatchA(R1, 1))
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
bNumeric = False: bAlpha = False: iStart = 0: iEnd = 0
'Load the first digit into an Object, then use the Boolean to separate into Alpha/Numeric handling
sChar = Left(Trim(UCase(arrMatchA(R1, 1))), 1)
'Skip this loop if there is no value to test
If sChar = Empty Then GoTo BlankValue
'Create objects used for reviewing the First Character
bNumeric = IsNumeric(sChar)
iAscii = Asc(sChar)
If iAscii >= 65 And iAscii <= 90 Then bAlpha = True
'KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK
'BarryAllen 2.0 Test & React
'........................................................................................
'Handle Numeric
'........................................................................................
If bNumeric = True Then
'Check Array that holds #A - if First Row is present (Col 5), Run 2nd test
If Chr(iAscii) = a123ABC(iAscii - 47, 1) And a123ABC(iAscii - 47, 5) <> "" Then
'Check to see if the string is in the Array[#A]
If InStr(1, a123ABC(iAscii - 47, 7), arrMatchA(R1, 1), vbTextCompare) <> 0 Then
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'Use the First/Last Row defined in the Array[#A] to execute a loop
For R2 = a123ABC(iAscii - 47, 5) To a123ABC(iAscii - 47, 6)
'Set the String object used for matching
sTemp = UCase(arrMatchB(R2, 1))
If sMatch1 = sTemp Then
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'found a match - Load results 'myWs1(R1, 1) = arrCopy(R2, 1)
myWs1(arrMatchA(R1, 2), myWs1ColPaste) = myWs2(arrMatchB(R2, 2), myWs2ColCopy)
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
End If
Next R2
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
End If
End If
'........................................................................................
'........................................................................................
'Handle Alpha
'........................................................................................
ElseIf bAlpha = True Then
'Check Array that holds #A - if First Row is present (Col 5), Run 2nd test
If Chr(iAscii) = a123ABC(iAscii - 54, 1) And a123ABC(iAscii - 54, 5) <> "" Then
'Check to see if the string is in the Array[#A]
If InStr(1, a123ABC(iAscii - 54, 7), arrMatchA(R1, 1), vbTextCompare) <> 0 Then
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'Use the First/Last Row defined in the Array[#A] to execute a loop
For R2 = a123ABC(iAscii - 54, 5) To a123ABC(iAscii - 54, 6)
'Set the String object used for matching
sTemp = UCase(arrMatchB(R2, 1))
If sMatch1 = sTemp Then
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'found a match - Load results 'myWs1(R1, 1) = arrCopy(R2, 1)
myWs1(arrMatchA(R1, 2), myWs1ColPaste) = myWs2(arrMatchB(R2, 2), myWs2ColCopy)
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
End If
Next R2
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
End If
End If
'........................................................................................
'........................................................................................
'Handle everything else [~!@#$%^&*()_+`-={}|[]\:";'<>?,./]
'........................................................................................
Else
'Check Array that holds #A - if First Row is present (Col 5), Run 2nd test
If a123ABC(37, 5) <> "" Then
'Check to see if the string is in the Array[#A]
If InStr(1, a123ABC(37, 7), arrMatchA(R1, 1), vbTextCompare) <> 0 Then
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'Use the First/Last Row defined in the Array[#A] to execute a loop
For R2 = a123ABC(37, 5) To a123ABC(37, 6)
'Set the String object used for matching
sTemp = UCase(arrMatchB(R2, 1))
If sMatch1 = sTemp Then
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'found a match - Load results 'myWs1(R1, 1) = arrCopy(R2, 1)
myWs1(arrMatchA(R1, 2), myWs1ColPaste) = myWs2(arrMatchB(R2, 2), myWs2ColCopy)
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
End If
Next R2
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
End If
End If
End If
'........................................................................................
'KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'No Value to check (Skip loop)
BlankValue:
Next R1
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
'For R1 = LBound(a123ABC) To UBound(a123ABC)
' Debug.Print a123ABC(R1, 1) & " . " & a123ABC(R1, 2) & " . " & a123ABC(R1, 3) & " . " & a123ABC(R1, 4) & " . " & a123ABC(R1, 5)
'Next R1
Application.StatusBar = ""
End Function
Tools: Clean Worksheet (InsertTabOrClear) (udfReset99)
Public Function InsertTabOrClear(myNewName As String)
'----------------------------------------------------------------------------------------------------------
'Defines current tab - returns to it after working with new tab
'Checks for sheet with [String]: If found, CLEAR data
' If NOT found, ADD sheet
'----------------------------------------------------------------------------------------------------------
Dim iCurrentWs As Long, iTabLoop As Long, sCurrentWs As String, bExists As Boolean, iMatchWs As Long
bExists = False
If ActiveSheet.Name = myNewName Then Worksheets(1).Select
iCurrentWs = ActiveSheet.Index: sCurrentWs = ActiveSheet.Name
For iTabLoop = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(iTabLoop).Name = myNewName Then
bExists = True
iMatchWs = iTabLoop 'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Old Method: Delete sheet, then select sheet last used
'Application.DisplayAlerts = False:'Worksheets(iTabLoop).Delete:'Application.DisplayAlerts = True
'Worksheets(sCurrentWs).Select 'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Exit For
End If
Next iTabLoop
If bExists = True Then
udfReset99 (iTabLoop)
Else
'-------------------------------------------------------------------------
'add new sheet: rename
Sheets.Add after:=Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = myNewName
'-------------------------------------------------------------------------
End If
Worksheets(sCurrentWs).Select
End Function
Function udfReset99(myTempWs As Long)
Dim iLastWs As Long
iLastWs = ActiveSheet.Index
'Make sure the current Ws is not the same as the temp
If myTempWs = iLastWs Then
If iLastWs = 1 Then
iLastWs = 2
Else
iLastWs = iLastWs - 1
End If
End If
'Select the temp WS and clear the data
Worksheets(myTempWs).Select
Cells.Clear
'Delete the Used Range
Worksheets(myTempWs).UsedRange.Delete
Worksheets(myTempWs).UsedRange
'Go back to the original sheet
Worksheets(iLastWs).Select
End Function
'----------------------------------------------------------------------------------------------------------
'Defines current tab - returns to it after working with new tab
'Checks for sheet with [String]: If found, CLEAR data
' If NOT found, ADD sheet
'----------------------------------------------------------------------------------------------------------
Dim iCurrentWs As Long, iTabLoop As Long, sCurrentWs As String, bExists As Boolean, iMatchWs As Long
bExists = False
If ActiveSheet.Name = myNewName Then Worksheets(1).Select
iCurrentWs = ActiveSheet.Index: sCurrentWs = ActiveSheet.Name
For iTabLoop = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(iTabLoop).Name = myNewName Then
bExists = True
iMatchWs = iTabLoop 'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Old Method: Delete sheet, then select sheet last used
'Application.DisplayAlerts = False:'Worksheets(iTabLoop).Delete:'Application.DisplayAlerts = True
'Worksheets(sCurrentWs).Select 'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Exit For
End If
Next iTabLoop
If bExists = True Then
udfReset99 (iTabLoop)
Else
'-------------------------------------------------------------------------
'add new sheet: rename
Sheets.Add after:=Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = myNewName
'-------------------------------------------------------------------------
End If
Worksheets(sCurrentWs).Select
End Function
Function udfReset99(myTempWs As Long)
Dim iLastWs As Long
iLastWs = ActiveSheet.Index
'Make sure the current Ws is not the same as the temp
If myTempWs = iLastWs Then
If iLastWs = 1 Then
iLastWs = 2
Else
iLastWs = iLastWs - 1
End If
End If
'Select the temp WS and clear the data
Worksheets(myTempWs).Select
Cells.Clear
'Delete the Used Range
Worksheets(myTempWs).UsedRange.Delete
Worksheets(myTempWs).UsedRange
'Go back to the original sheet
Worksheets(iLastWs).Select
End Function
Tools: Sort (udf_Sort_FullSheet)
Function udf_Sort_FullSheet(myWs As Long, myCol As Long, myLastRow As Long, myLastCol As Long, bUseHeader As Boolean)
'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(myLastRow, myCol).Address), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets(myWs).Sort
.SetRange Range(Worksheets(myWs).Cells(1, 1).Address, Worksheets(myWs).Cells(myLastRow, myLastCol).Address)
If bUseHeader = True Then .Header = xlYes
If bUseHeader = False Then .Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Function
'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(myLastRow, myCol).Address), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets(myWs).Sort
.SetRange Range(Worksheets(myWs).Cells(1, 1).Address, Worksheets(myWs).Cells(myLastRow, myLastCol).Address)
If bUseHeader = True Then .Header = xlYes
If bUseHeader = False Then .Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Function
