Option Explicit
Sub GroupLinkedAccounts()
'
' Group Linked Accounts
'
Dim lrSrc As Long, lrLA As Long
Dim r As Long
Dim rPrimary As Long, rSecondary As Long
Dim rLastPrimary As Long
Dim rng As Range, rngLA As Range
Dim rngLA2 As Range
Dim rngprev As Range
Dim rngSrc As Range
Dim wksLA As Worksheet 'Linked Accounts worksheet
Dim wksSrc As Worksheet
Dim Acct1, idx
Dim rPrevIsPrimary As Long, rIsPrimary As Long
Set wksSrc = ActiveSheet
Set wksLA = Worksheets("Linked_Accounts")
lrSrc = wksSrc.Range("A" & Rows.Count).End(xlUp).Row
lrLA = wksLA.Range("A" & Rows.Count).End(xlUp).Row
Set rngLA = wksLA.Range("A2:A" & lrLA)
Set rngLA2 = wksLA.Range("B2:B" & lrLA)
'
SortAmountMaxToMin 'separate macro/sub
rPrimary = 1
rLastPrimary = 1
rSecondary = 2
For r = 3 To lrSrc
Range("A" & r & ":C" & r).Select
'Is the value in Row r a Primary account number
'find account number in linked account list
' On Error GoTo end_of_loop_1
On Error Resume Next
With WorksheetFunction
Set rngprev = wksSrc.Range("A" & r - 1 & ":C" & r - 1)
rPrevIsPrimary = 0
rPrevIsPrimary = .Match(rngprev(1), rngLA, 0)
rIsPrimary = 0
rIsPrimary = .Match(Selection(1), rngLA, 0)
If rIsPrimary > 0 Then rLastPrimary = r
End With
If Not rPrevIsPrimary And rIsPrimary Then
rPrimary = rPrimary + 1
Selection.Cut
wksSrc.Range("A" & rPrimary & ":C" & rPrimary).Select
Selection.Insert Shift:=xlDown
End If
end_of_loop_1:
'Debug.Print Err.Number, Err.Description
Next r
'Now match up Primary and Secondary Accounts
'All the primary accounts are at the top of the list
'rPrimary - 1 (minus one) should be the last Primary record in the list
'if there are no primary accounts in the list exit
If rLastPrimary = 0 Then Exit Sub
Set rngSrc = wksSrc.Range("A2:A" & lrSrc)
For r = rLastPrimary To lrSrc
Range("A" & r & ":C" & r).Select
On Error Resume Next
With WorksheetFunction
idx = 0
Acct1 = 0
idx = .Match(Selection(1), rngLA2, 0)
If idx > 0 Then
Acct1 = .Index(rngLA, idx)
End If
End With
If Acct1 > 0 Then
rPrimary = 0
rPrimary = WorksheetFunction.Match(Acct1, rngSrc, 0) + 1
If rPrimary > 0 Then
rSecondary = rPrimary + 1
Selection.Cut
wksSrc.Range("A" & rSecondary & ":C" & rSecondary).Select
Selection.Insert Shift:=xlDown
End If
End If
Next r
End Sub
Sub SortAmountMaxToMin()
'
' SortAmountMaxToMin
'
'
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C2:C9"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:C9")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
