Resources
  • Home
  • December-Chrono
  • Psalm136Personalized
  • ExcelResources
    • 99PublicFunctions
    • aDelimitedCodeTemplate
    • aCodeTemplate
    • aBetter_Code_Template
    • ApplyFormulaValue
    • ArrayPublic
    • ArrayMatchCopyRow
    • Capitalization
    • Colors
    • DataTypes
    • DeleteRows
    • Filter
    • FormatStandard
    • Forms
    • Grid
    • Headers
    • ImageScrape
    • InputBox
  • ExcelResources2
    • Like
    • List Review
    • MatchAndReturn
    • mod_Import
    • Numbers
    • PDF_Parse
    • RandomGenerator
    • iRe1
    • Rept
    • RelatedItemsLIst
    • RomanNumerals
    • SheetSplitter
    • Sort
    • Split Method
    • String_DataType
    • TabDelimited
    • Tab_InsertNew_or_ClearExisting
    • Unique_List
      • UniqueLIsts_FilterMethod
  • Excelresources_Files
    • FileLists
    • FileTextParse
    • Folders
  • excelresources_WebScrape
    • CreateList_1-Href_2-Jpg
    • TableData_Load_PlugPlay
    • CreateList_MultiPage_Image_Link
      • ImageDownload_WebLink_List
    • TableData_Load_ClassDiv
    • TableData_Load_ClassSpan
  • Houseboat Vacation
  • At the Foot of the King
  • Devotions
  • Mentoring
  • Inspirational Stories
    • Vacuum Lifting
  • Job Help
  • Resources
    • MS
    • Florida History
  • Contact
  • Heroscape
    • Fish
    • Playstation
  • You Tube Videos
  • House
    • Tiny Houses
    • Backyards
  • CampingResources
    • CampingLand
    • LED Throwies
  • Interesting
  • Recipes
  • Xbox
  • Skydiving
  • ReadingPlan-5Year
  • Desoto
  • BibleStudy
  • HurricaneIrma
  • Home
  • December-Chrono
  • Psalm136Personalized
  • ExcelResources
    • 99PublicFunctions
    • aDelimitedCodeTemplate
    • aCodeTemplate
    • aBetter_Code_Template
    • ApplyFormulaValue
    • ArrayPublic
    • ArrayMatchCopyRow
    • Capitalization
    • Colors
    • DataTypes
    • DeleteRows
    • Filter
    • FormatStandard
    • Forms
    • Grid
    • Headers
    • ImageScrape
    • InputBox
  • ExcelResources2
    • Like
    • List Review
    • MatchAndReturn
    • mod_Import
    • Numbers
    • PDF_Parse
    • RandomGenerator
    • iRe1
    • Rept
    • RelatedItemsLIst
    • RomanNumerals
    • SheetSplitter
    • Sort
    • Split Method
    • String_DataType
    • TabDelimited
    • Tab_InsertNew_or_ClearExisting
    • Unique_List
      • UniqueLIsts_FilterMethod
  • Excelresources_Files
    • FileLists
    • FileTextParse
    • Folders
  • excelresources_WebScrape
    • CreateList_1-Href_2-Jpg
    • TableData_Load_PlugPlay
    • CreateList_MultiPage_Image_Link
      • ImageDownload_WebLink_List
    • TableData_Load_ClassDiv
    • TableData_Load_ClassSpan
  • Houseboat Vacation
  • At the Foot of the King
  • Devotions
  • Mentoring
  • Inspirational Stories
    • Vacuum Lifting
  • Job Help
  • Resources
    • MS
    • Florida History
  • Contact
  • Heroscape
    • Fish
    • Playstation
  • You Tube Videos
  • House
    • Tiny Houses
    • Backyards
  • CampingResources
    • CampingLand
    • LED Throwies
  • Interesting
  • Recipes
  • Xbox
  • Skydiving
  • ReadingPlan-5Year
  • Desoto
  • BibleStudy
  • HurricaneIrma
Connect on Facebook

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

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



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

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

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

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

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
Powered by Create your own unique website with customizable templates.
  • Home
  • December-Chrono
  • Psalm136Personalized
  • ExcelResources
    • 99PublicFunctions
    • aDelimitedCodeTemplate
    • aCodeTemplate
    • aBetter_Code_Template
    • ApplyFormulaValue
    • ArrayPublic
    • ArrayMatchCopyRow
    • Capitalization
    • Colors
    • DataTypes
    • DeleteRows
    • Filter
    • FormatStandard
    • Forms
    • Grid
    • Headers
    • ImageScrape
    • InputBox
  • ExcelResources2
    • Like
    • List Review
    • MatchAndReturn
    • mod_Import
    • Numbers
    • PDF_Parse
    • RandomGenerator
    • iRe1
    • Rept
    • RelatedItemsLIst
    • RomanNumerals
    • SheetSplitter
    • Sort
    • Split Method
    • String_DataType
    • TabDelimited
    • Tab_InsertNew_or_ClearExisting
    • Unique_List
      • UniqueLIsts_FilterMethod
  • Excelresources_Files
    • FileLists
    • FileTextParse
    • Folders
  • excelresources_WebScrape
    • CreateList_1-Href_2-Jpg
    • TableData_Load_PlugPlay
    • CreateList_MultiPage_Image_Link
      • ImageDownload_WebLink_List
    • TableData_Load_ClassDiv
    • TableData_Load_ClassSpan
  • Houseboat Vacation
  • At the Foot of the King
  • Devotions
  • Mentoring
  • Inspirational Stories
    • Vacuum Lifting
  • Job Help
  • Resources
    • MS
    • Florida History
  • Contact
  • Heroscape
    • Fish
    • Playstation
  • You Tube Videos
  • House
    • Tiny Houses
    • Backyards
  • CampingResources
    • CampingLand
    • LED Throwies
  • Interesting
  • Recipes
  • Xbox
  • Skydiving
  • ReadingPlan-5Year
  • Desoto
  • BibleStudy
  • HurricaneIrma