Processing


Dim gvaPositionsPrevious As Variant 
Dim gvaPositionsCurrent As Variant

Public Enum enARRAY_ENUM
    eKey
    eName
    eDescription
    ePrevious
    eCurrent
End Enum

Public Sub Arrays_Processing()

Dim lcount_previous As Long
Dim lcount_current As Long
Dim blast_previous As Boolean
Dim blast_current As Boolean
Dim lrow_output As Long
Dim boutput_previous As Boolean
Dim boutput_current As Boolean
Dim boutput_both As Boolean

    On Error GoTo ErrorHandler

    gvaPositionsPrevious = Range("PositionsPrevious").Value
    gvaPositionsCurrent = Range("PositionsCurrent").Value
    lrow_output = 3
    lcount_previous = 1
    lcount_current = 1
    Sheets("Previous vs Current").Select
    Range("B3:I5000").ClearContents
    With Sheets("Previous vs Current")

        Do Until ((blast_previous = True) And (blast_current = True))

            boutput_both = False
            boutput_current = False
            boutput_previous = False
            If (blast_previous = True) Then boutput_current = True
            If (blast_current = True) Then boutput_previous = True
            If ((blast_previous = False) And _
                (blast_current = False)) Then
                If (gvaPositionsPrevious(lcount_previous, enARRAY_ENUM.eKey) = _
                    gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eKey)) Then
                    boutput_both = True
                Else
                    If (gvaPositionsPrevious(lcount_previous, enARRAY_ENUM.eKey) < _
                        gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eKey)) Then
                        boutput_previous = True
                    Else
'therefore Previous > Current, so display Current
                        boutput_current = True
                    End If
                End If
            End If

            If (boutput_both = True) Then
                .Range("B" & lrow_output).Value = _
                      gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eName)
                .Range("C" & lrow_output).Value = _
                      gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eDescription)
'display previous
                .Range("D" & lrow_output).Value = _
                      gvaPositionsPrevious(lcount_current, enARRAY_ENUM.ePrevious)
'display current
                .Range("E" & lrow_output).Value = _
                      gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eCurrent)
                If (lcount_previous = UBound(gvaPositionsPrevious, 1)) Then
                   blast_previous = True
                End If
                If (lcount_previous < UBound(gvaPositionsPrevious, 1)) Then
                   lcount_previous = lcount_previous + 1
                End If
                If (lcount_current = UBound(gvaPositionsCurrent, 1)) Then
                   blast_current = True
                End If
                If (lcount_current < UBound(gvaPositionsCurrent, 1)) Then
                   lcount_current = lcount_current + 1
                End If
            End If

            If (boutput_previous = True) Then
                .Range("B" & lrow_output).Value = _
                    gvaPositionsPrevious(lcount_current, enARRAY_ENUM.eName)
                .Range("C" & lrow_output).Value = _
                    gvaPositionsPrevious(lcount_current, enARRAY_ENUM.eDescription)
'display previous
                .Range("D" & lrow_output).Value = _
                    gvaPositionsPrevious(lcount_current, enARRAY_ENUM.ePrevious)
                If (lcount_previous = UBound(gvaPositionsPrevious, 1)) Then
                    blast_previous = True
                End If
                If (lcount_previous < UBound(gvaPositionsPrevious, 1)) Then
                    lcount_previous = lcount_previous + 1
                End If
            End If

            If (boutput_current = True) Then
                .Range("B" & lrow_output).Value = _
                   gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eName)
                .Range("C" & lrow_output).Value = _
                   gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eDescription)
'display current
                .Range("E" & lrow_output).Value = _
                   gvaPositionsCurrent(lcount_current, enARRAY_ENUM.eCurrent)
                If (lcount_current = UBound(gvaPositionsCurrent, 1)) Then
                   blast_current = True
                End If
                If (lcount_current < UBound(gvaPositionsCurrent, 1)) Then
                   lcount_current = lcount_current + 1
                End If
            End If

'Difference between current and previous
            .Range("F" & lrow_output).FormulaR1C1 = "RC[-1]-RC[-2]"
            lrow_output = lrow_output + 1
        Loop
    End With
    Range("B3").Sort Key1:=Range("C3"), Order1:=xlAscending, _
                     Key2:=Range("C4"), Order2:=xlAscending, Header:=xlYes
    Exit Sub

ErrorHandler:
End Sub

Public Sub MatchingArrays() 
'Dim vArray1 As Variant
'Dim vArray2 As Variant
Dim larray1_count As Long
Dim larray2_count As Long
Dim barray1_last As Boolean
Dim barray2_last As Boolean

Dim lcount_combined As Long

ReDim vCombinedList(1 To UBound(vArray1, 1) + UBound(vArray2, 1))

larray1_count = 1
larray2_count = 1
lcount_combined = 1

Do Until (barray1_last = True) And (barray2_last = True)

If vArray1(larray1_count) = vArray2(larray2_count) Then

vCombinedList(lcount_combined) = vArray1(larray1_count)
lcount_combined = lcount_combined + 1

If larray1_count < UBound(vArray1, 1) Then larray1_count = larray1_count + 1
If larray2_count < UBound(vArray2, 1) Then larray2_count = larray2_count + 1

If larray1_count = UBound(vArray1, 1) Then barray1_last = True
If larray2_count = UBound(vArray2, 1) Then barray2_last = True
Else
If vArray1(larray1_count) < vArray2(larray2_count) Then

If larray1_count = UBound(vArray1, 1) Then barray1_last = True
If larray1_count < UBound(vArray1, 1) Then larray1_count = larray1_count + 1
Else

If larray2_count = UBound(vArray2, 1) Then barray2_last = True
If larray2_count < UBound(vArray2, 1) Then larray2_count = larray2_count + 1
End If
End If
Loop

ReDim Preserve vCombinedList(1 To lcount_combined - 1)

Stop

End Sub

Public Sub RelationshipList_PopulateAdditionalColumns() 
Const sPROCNAME As String = "RelationshipList_PopulateAdditionalColumns"

Dim vRelationshipList As Variant
Dim vAdditionalColumns As Variant
Dim oStartCell As Excel.Range
Dim oFinishCell As Excel.Range
Dim oRange As Excel.Range
Dim llastrow As Long
Dim lcount As Long
Dim spasterange As String

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)
    
    vRelationshipList = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(g_sRELATIONSHIPLIST_NAMERANGE).Value
    
    ReDim vAdditionalColumns(1 To UBound(vRelationshipList, 1), 1 To 2)
    
    For lcount = 1 To UBound(vRelationshipList, 1)
        If (vRelationshipList(lcount, g_enRELATIONSHIPLIST.FirmId) <> "RM") Then
            vAdditionalColumns(lcount, 1) = UCase(vRelationshipList(lcount, g_enRELATIONSHIPLIST.CompanyName))
            vAdditionalColumns(lcount, 2) = _
               modGeneral.Str_FunnyChars_Remove(UCase(vRelationshipList(lcount, g_enRELATIONSHIPLIST.MatchingName)))
        End If
    Next lcount
    
    llastrow = g_lSTARTROW + Range(g_sRELATIONSHIPLIST_NAMERANGE).Rows.Count - 1
    
    Set oStartCell = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Cells(g_lSTARTROW, g_enRELATIONSHIP_LIST_COLUMNS.RL_CompanyName_Capitals)
    Set oFinishCell = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Cells(llastrow, g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals)
    Set oRange = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(oStartCell.Address & ":" & oFinishCell.Address)
    oRange.Value = vAdditionalColumns

    Set oStartCell = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Cells(g_lSTARTROW, g_enRELATIONSHIP_LIST_COLUMNS.RL_FirmID)
    Set oFinishCell = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Cells(llastrow, g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals)
    Set oRange = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(oStartCell.Address & ":" & oFinishCell.Address)
    spasterange = oRange.Address
    Application.Names.Add Name:=g_sRELATIONSHIPLIST_NAMERANGE, RefersTo:=Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(spasterange)

    Call RelationshipList_DefineNamedRanges(llastrow)

    Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals) & g_lSTARTROW).Sort _
        Key1:=Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals) & g_lSTARTROW), Header:=xlYes

    Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub


Matches two tables (with a common column) and brings in columns from one table across to the other table

Public Sub RelationshipList_Matching_PopulateTargetListColumns() 

Const sPROCNAME As String = "RelationshipList_Matching_PopulateTargetListColumns"

Dim vRelationshipList As Variant
Dim vTargetList As Variant
Dim ltarget_count As Long
Dim lrelation_count As Long
Dim btarget_last As Boolean
Dim brelation_last As Boolean

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

    vRelationshipList = Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(g_sRELATIONSHIPLIST_NAMERANGE).Value
    vTargetList = Sheets(g_sWSHNAME_TARGET_LIST).Range(g_sTARGETLIST_NAMERANGE).Value

    ltarget_count = 1
    lrelation_count = 1
    Do Until (btarget_last = True) And (brelation_last = True)
        
        If (vTargetList(ltarget_count, g_enTARGETLIST.FirmName_Capitals) = _
            vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.MatchingName_Capitals)) Then
        
            If (Len(vTargetList(ltarget_count, g_enTARGETLIST.FUM)) > 0) Then
                vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.FUM) = vTargetList(ltarget_count, g_enTARGETLIST.FUM)
            Else
                vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.FUM) = 0
            End If
            
            vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.Classification) = vTargetList(ltarget_count, g_enTARGETLIST.FirmType)
            vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.Region) = vTargetList(ltarget_count, g_enTARGETLIST.Region)
            
            If (ltarget_count = UBound(vTargetList, 1)) Then btarget_last = True
            If (lrelation_count = UBound(vRelationshipList, 1)) Then
                brelation_last = True
                btarget_last = True
            End If
            
            If (lrelation_count < UBound(vRelationshipList, 1)) Then lrelation_count = lrelation_count + 1
        Else
            If (vTargetList(ltarget_count, g_enTARGETLIST.FirmName_Capitals) < _
                vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.MatchingName_Capitals)) Then

                If (ltarget_count = UBound(vTargetList, 1)) Then
                    btarget_last = True
                    brelation_last = True
                End If
                If (ltarget_count < UBound(vTargetList, 1)) Then ltarget_count = ltarget_count + 1
            Else

                If (lrelation_count = UBound(vRelationshipList, 1)) Then
                    brelation_last = True
                    btarget_last = True
                End If
                If (lrelation_count < UBound(vRelationshipList, 1)) Then lrelation_count = lrelation_count + 1
            End If
        
        End If
    Loop

    Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(g_sRELATIONSHIPLIST_NAMERANGE).Value = vRelationshipList

    Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_CompanyName_Capitals) & g_lSTARTROW).Sort _
        Key1:=Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_CompanyName_Capitals) & g_lSTARTROW), Header:=xlYes

    Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub


Public Function RelationshipList_Lookup_TargetNameLinking(ByVal sLookup As String) As String 
Dim sfindmatch As String
Dim lmatchrow As Long
    On Error GoTo ErrorHandler
    sfindmatch = Application.WorksheetFunction.VLookup(sLookup, Range(g_sRELATIONSHIPLIST_NAMERANGE_LOOKUPLINKING), 2, False)
    lmatchrow = Application.WorksheetFunction.Match(sLookup, Range(g_sRELATIONSHIPLIST_NAMERANGE_MATCHFIRMNAME), 0) + 4
    If Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_FirmID) & lmatchrow).Value = "RM" Then
        sfindmatch = ""
    End If
    RelationshipList_Lookup_TargetNameLinking = sfindmatch
    Exit Function
ErrorHandler:
    RelationshipList_Lookup_TargetNameLinking = ""
End Function


Public Function CompaniesMeet_Lookup_CompanyNameExists(ByVal sLookup As String) As Boolean 
Dim sfindmatch As String
Dim llastrow As Long
    On Error GoTo ErrorHandler
    sfindmatch = Application.WorksheetFunction.VLookup(sLookup, Range(g_sCOMPANIESMEET_NAMERANGE_LOOKUP_RELATIONSHIP), 1, False)
    CompaniesMeet_Lookup_CompanyNameExists = True
    Exit Function
ErrorHandler:
    CompaniesMeet_Lookup_CompanyNameExists = False
End Function


Public Sub CompaniesMeet_Matching_PopulateRelationshipListColumns() 

Const sPROCNAME As String = "CompaniesMeet_Matching_PopulateRelationshipListColumns"

Dim vRelationshipList As Variant
Dim vCompaniesMeetList As Variant
Dim lrelation_count As Long
Dim lcompanies_count As Long
Dim lrowcount As Long
Dim brelation_last As Boolean
Dim bcompanies_last As Boolean

    On Error GoTo ErrorHandler
    Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

    Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(g_sRELATIONSHIPLIST_NAMERANGE).Sort _
        Key1:=Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_CompanyName_Capitals) & g_lSTARTROW), _
        Order1:=XlSortOrder.xlAscending, _
        Header:=xlYes

    vRelationshipList = RelationshipList_FilteringToArray()
    If (VBA.IsNull(vRelationshipList) = True) Then
        Exit Sub
    End If
    
    Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals) & g_lSTARTROW).Sort _
        Key1:=Sheets(g_sWSHNAME_RELATIONSHIP_LIST).Range(Col_Letter(g_enRELATIONSHIP_LIST_COLUMNS.RL_MatchingName_Capitals) & g_lSTARTROW), Header:=xlYes

    vCompaniesMeetList = Sheets(g_sWSHNAME_SERVICED).Range(g_sCOMPANIESMEET_NAMERANGE).Value
    
    For lrowcount = 1 To UBound(vCompaniesMeetList, 1)
        vCompaniesMeetList(lrowcount, 2) = _
            modGeneral.Str_FunnyChars_Substitute(vCompaniesMeetList(lrowcount, 2))
    Next lrowcount
    
    vCompaniesMeetList = Array_Transpose(vCompaniesMeetList)
    Call Array_SortQuickMulti1ColRowVariant("Companies Meet", vCompaniesMeetList, g_enCOMPANIESMEET.CompanyName_Capitals)
    vCompaniesMeetList = Array_Transpose(vCompaniesMeetList)
    
    lrelation_count = 1
    lcompanies_count = 1
    Do Until (brelation_last = True) And (bcompanies_last = True)
        
        If (vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.CompanyName_Capitals) = _
            vCompaniesMeetList(lcompanies_count, g_enCOMPANIESMEET.CompanyName_Capitals)) Then
        
            vCompaniesMeetList(lcompanies_count, g_enCOMPANIESMEET.Classification) = _
                vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.Classification)
            
            vCompaniesMeetList(lcompanies_count, g_enCOMPANIESMEET.MatchingName_Capitals) = _
                vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.MatchingName_Capitals)
            
            If (lrelation_count = UBound(vRelationshipList, 1)) Then brelation_last = True
            If (lcompanies_count = UBound(vCompaniesMeetList, 1)) Then
                bcompanies_last = True
                brelation_last = True
            End If
            
            If (lcompanies_count < UBound(vCompaniesMeetList, 1)) Then lcompanies_count = lcompanies_count + 1
        Else
            If (vRelationshipList(lrelation_count, g_enRELATIONSHIPLIST.CompanyName_Capitals) < _
                vCompaniesMeetList(lcompanies_count, g_enCOMPANIESMEET.CompanyName_Capitals)) Then

                If (lrelation_count < UBound(vRelationshipList, 1)) Then lrelation_count = lrelation_count + 1
                If (lrelation_count = UBound(vRelationshipList, 1)) Then
                    brelation_last = True
                    If (lcompanies_count < UBound(vCompaniesMeetList, 1)) Then lcompanies_count = lcompanies_count + 1
                    If (lcompanies_count <= UBound(vCompaniesMeetList, 1)) Then bcompanies_last = True
                End If
            Else

                If (lcompanies_count = UBound(vCompaniesMeetList, 1)) Then
                    bcompanies_last = True
                    brelation_last = True
                End If
                If (lcompanies_count < UBound(vCompaniesMeetList, 1)) Then lcompanies_count = lcompanies_count + 1
            End If
        
        End If
    Loop

    vCompaniesMeetList = Array_Transpose(vCompaniesMeetList)
    Call Array_SortQuickMulti1ColRowVariant("Companies Meet", vCompaniesMeetList, g_enCOMPANIESMEET.CompanyName_Capitals)
    vCompaniesMeetList = Array_Transpose(vCompaniesMeetList)
    
    Sheets(g_sWSHNAME_SERVICED).Range(g_sCOMPANIESMEET_NAMERANGE).Value = vCompaniesMeetList

    For lrowcount = 1 To Range(g_sCOMPANIESMEET_NAMERANGE).Rows.Count
        If (Range(g_sCOMPANIESMEET_NAMERANGE).Cells(lrowcount, 2).Value = g_sINSTITUTION) Then
            With Sheets(g_sWSHNAME_SERVICED)
                .Range(.Cells(4 + lrowcount, 3), .Cells(4 + lrowcount, 5)).Interior.Color = g_lCOLOUR_INSTITUTION_GREY
            End With
        End If
    Next lrowcount

    Exit Sub
ErrorHandler:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub



© 2025 Better Solutions Limited. All Rights Reserved. © 2025 Better Solutions Limited TopPrevNext