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