Ownership Partners Grouping using excel VBA - excel

Question

I have data which shows the acquisition of property from one partner to another and transfer of properties. Based on the inactive date and then seeing the document date I have to detect the transfer of property. Here is the snap of data:
For example in the second picture when the contract inactive date passes, ownership transfers to other having document date of the next day. Like in first group the 13th one William G & ALMA have ownership now look inactive date it is 10/3/1971, now I will find the next day date in document dates which I found 10/4/1971 for ALMA TEST TR, therefore, ownership transferred to him and new partners are WILLIAM G & ALMA TEST TR as both make to 100% of ownership. Here the output I have done manually but I need a VBA code to make it easier as I am new to VBA here is the required output.
Here is my code:
Sub DateFill()
Dim rng As Range, destRow As Long
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim c As Range '-- this is used to store the single cell in the For Each loop
Set shtSrc = Sheets("Input") ' Sets "Sheet1" sheet as source sheet
Set shtDest = Sheets("Output") 'Sets "Sheet2." sheet as destination sheet
destRow = 2 'Start copying to this row on destination sheet
Dim x, y, i As Long
y = Array("ERROR", "(ERROR)") ' To delete rows having the name error to clean data
With ActiveSheet.UsedRange.Columns(1)
x = .Value
For i = 1 To UBound(x, 1)
If Not IsError(Application.Match(LCase(x(i, 1)), y, 0)) Then x(i, 1) = ""
Next
.Value = x
.SpecialCells(4).EntireRow.Delete
End With
' >> Look for matching dates in columns F to G <<
For Each c In rng.Cells
If (c.Offset(0, 2).Value + 1 = c.Offset(1, 3).Value) Then
shtSrc.Range("A" & c.Row).Copy shtDest.Range("A" & destRow)
shtSrc.Range("B" & c.Row).Copy shtDest.Range("B" & destRow)
shtSrc.Range("C" & c.Row).Copy shtDest.Range("C" & destRow)
shtSrc.Range("D" & c.Row).Copy shtDest.Range("D" & destRow)
shtSrc.Range("E" & c.Row).Copy shtDest.Range("E" & destRow)
shtSrc.Range("F" & c.Row).Copy shtDest.Range("F" & destRow)
shtSrc.Range("G" & c.Row).Copy shtDest.Range("G" & destRow)
destRow = destRow + 1
' > Ends search for dates <
End If
Next
End Sub
It's over my knowledge level. Any help would be appreciated, as I can't seem to figure this code out. If you could explain how this works in simple terms, that would be equally awesome!

Answer 1

I used the following data as sheet "Data". Note that the columns need to be in exactly this order and position. The code addresses the columns by A, B, C …
Note that I used another date format, but the code will work with any other date format too, as long as the cells contain real dates and not strings.
The following code has to be in a module. You need to specify your sheet names.
Option Explicit
Global wsData As Worksheet
Global wsDest As Worksheet
Global LastRow As Long
Global LastCol As Long
Global GroupCounter As Long
Public Sub ExtractGroups()
Set wsData = ThisWorkbook.Worksheets("Data") 'specify source sheet
Set wsDest = ThisWorkbook.Worksheets("Groups") 'specify destination sheet
LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
LastCol = wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column
GroupCounter = 0
'## Sort data
With wsData.Sort
.SortFields.Clear
'sort by Acquistion Date, Document Date and Inactive Date
.SortFields.Add Key:=Range("E2:E" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("F2:F" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("G2:G" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange wsData.UsedRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'## Find first group
Dim iRow As Long
iRow = LastRow
Dim IntSum As Double
Do While IntSum + wsData.Cells(iRow, "C").Value <= 100
IntSum = IntSum + wsData.Cells(iRow, "C").Value
Application.CutCopyMode = False
wsDest.Rows(2).Insert xlDown
wsData.Rows(iRow).Resize(ColumnSize:=LastCol).Copy
wsDest.Rows(2).Cells(1, "A").Value = GroupCounter
wsDest.Rows(2).Cells(1, "B").PasteSpecial xlPasteAll
iRow = iRow - 1
Loop
'## Analyze the data
Dim GroupRows As Long
GroupRows = LastRow - iRow
Dim destRow As Long, FirstGroupRow As Long, FirstDate As Date, AddedRows As Long
Do While GroupRows >= 0
GroupCounter = GroupCounter + 1
FirstGroupRow = 2
AddedRows = 0
destRow = 2 + GroupRows - 1
FirstDate = 0
GroupRows = 0
Do While destRow + GroupRows >= FirstGroupRow + GroupRows
If FirstDate = 0 Then
If Not IsDate(wsDest.Cells(destRow + GroupRows, "H").Value) Then Exit Do
FirstDate = wsDest.Cells(destRow + GroupRows, "H").Value
GroupRows = GroupRows + AddNextOwners(wsDest.Cells(destRow + GroupRows, "H").Value + 1)
ElseIf FirstDate <> wsDest.Cells(destRow + GroupRows, "H").Value Then
GroupRows = GroupRows + 1
Application.CutCopyMode = False
wsDest.Rows(2).Insert xlDown
wsDest.Rows(destRow + GroupRows).Resize(ColumnSize:=LastCol - 1).Offset(ColumnOffset:=1).Copy
wsDest.Rows(2).Cells(1, "A").Value = GroupCounter
wsDest.Rows(2).Cells(1, "B").PasteSpecial xlPasteAll
End If
destRow = destRow - 1
Loop
If GroupRows = 0 Then Exit Do
'## Sort within the group
With wsDest.Sort
.SortFields.Clear
.SortFields.Add Key:=wsDest.Range("H2").Resize(RowSize:=GroupRows), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange wsDest.Rows("2").Resize(RowSize:=GroupRows)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'## color every second group
With wsDest.Rows("2").Resize(RowSize:=GroupRows).Interior
If GroupCounter Mod 2 = 0 Then
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
Else
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End If
End With
'## check if group int exceeds 100 %
If Application.WorksheetFunction.Sum(wsDest.Range("D2").Resize(RowSize:=GroupRows)) > 100 Then
MsgBox "'Int' in group " & GroupCounter & " exceeded 100 %. Please fix the source data.", vbCritical
'ReNumberGroups
Exit Sub
End If
DoEvents
Loop
'ReNumberGroups
'## everything was going correctly!
MsgBox "Mission accomplished!", vbInformation
End Sub
'## Substitute the old owner with the new ones (for the next group)
Private Function AddNextOwners(DocDate As Date) As Long
Dim iRow As Long
For iRow = LastRow To 2 Step -1
If wsData.Cells(iRow, "F").Value = DocDate Then
AddNextOwners = AddNextOwners + 1
Application.CutCopyMode = False
wsDest.Rows(2).Insert xlDown
wsData.Rows(iRow).Resize(ColumnSize:=LastCol).Copy
wsDest.Rows(2).Cells(1, "A").Value = GroupCounter
wsDest.Rows(2).Cells(1, "B").PasteSpecial xlPasteAll
End If
Next iRow
End Function
And it will end up with the worksheet "Groups" like this below.
Note that the algorithm fails in the end because of some data inconsistency.
If you want the group numbers the other way round use …
Private Sub ReNumberGroups()
Dim iRow As Long
Const StartGroupNumber As Long = 1 'define first group number
For iRow = 2 To wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row
wsDest.Cells(iRow, "A").Value = GroupCounter - wsDest.Cells(iRow, "A").Value + StartGroupNumber
Next iRow
End Sub