Excel Macro append duplicates to first line - vba

Question

I'm an Excel VBA newbie and i'm trying to get the duplicates rows to appends to the first occurence of that row.
Per exemple we have the table here
I would like to format data as here
The logic goes like this. Whenever we detect that the last name and the birth date are the same for the current and following line that mean we have a dependant and we need to append the dependant's data to the "Main"
I have started writing code but i'm not able to detect the dependants properly.
Below is what i have. please consider that i'm a real noob and i'm trying hard.
Sub formatData()
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer
'This variable is checked to see if we have a first occurence of a line
Dim firstOccurence
'Initialise the variables for that will be used to match the data
Dim LocationName
Dim PlanCode
Dim LastName
Dim FirstName
Dim dependantFirstName
Dim dependantLastName
Dim dependantBirthdate
RowCount = 0
firstOccurence = True
'Check if the spreadsheet already exist if not create it.
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Benefits Census Formatted" Then
exists = True
End If
Next i
If Not exists Then
'Create a new spreadsheet to add the data to
Set ws = Sheets.Add
Sheets.Add.Name = "Benefits Census Formatted"
End If
'Set the ActiveSheet to the one containing the original data
Set sh = Sheets("BENEFIT Census")
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each rw In sh.Rows
'If the data of one cell is empty EXIT THE LOOP
If sh.Cells(rw.Row, 1).Value = "" Then
Exit For
End If
If rw.Row > 1 Then
'Afffecting the variables to the next loop so we can compare the values
nextLocationName = sh.Cells(rw.Row + 1, 1).Value
nextPlanCode = sh.Cells(rw.Row + 1, 2).Value
nextLastName = sh.Cells(rw.Row + 1, 3).Value
nextFirstName = sh.Cells(rw.Row + 1, 4).Value
nextEmploymentDate = sh.Cells(rw.Row + 1, 5).Value
nextBirthDate = sh.Cells(rw.Row + 1, 6).Value
nextDependantFirstName = sh.Cells(rw.Row + 1, 25).Value
nextDependantLastName = sh.Cells(rw.Row + 1, 26).Value
nextDependantBirthdate = sh.Cells(rw.Row + 1, 27).Value
Debug.Print LastName & " - " & FirstName & " ::: " & nextLastName & " - " & nextFirstName & " : " & rw.Row & " : " & firstOccurence
'First time you pass through the loop write the whole lane
If firstOccurence = True Then
'Affecting the variables to the current loops values
LocationName = sh.Cells(rw.Row, 1).Value
PlanCode = sh.Cells(rw.Row, 2).Value
LastName = sh.Cells(rw.Row, 3).Value
FirstName = sh.Cells(rw.Row, 4).Value
dependantFirstName = sh.Cells(rw.Row, 25).Value
dependantLastName = sh.Cells(rw.Row, 26).Value
dependantBirthdate = sh.Cells(rw.Row, 27).Value
'Write the current line
sh.Rows(rw.Row).Copy
'We copy the value into another sheet
Set ns = Sheets("Benefits Census Formatted")
LastRow = ns.Cells(ns.Rows.Count, "A").End(xlUp).Row + 1
ns.Rows(LastRow).PasteSpecial xlPasteValues
firstOccurence = False
Else
'We match the location with the plan code and the last name and first name of the user to find duplicates
If dependantFirstName <> nextDependantFirstName And PlanCode <> nextPlanCode And LastName <> nextLastName And FirstName <> nextFirstName Then
'We find a different dependant if the first name or the last name or the birthdate differs
'If Not (dependantFirstName <> nextDependantFirstName) Or Not (dependantLastName <> nextDependantLastName) Or Not (dependantBirthdate <> nextDependantBirthdate) Then
'We have a dependant Append it to the line
'append the user to the currentLine
'End If
Else
'If the dependantFirstName and the nextDependant First name doesn't match then on the next loop we print the full line
firstOccurence = True
End If
End If
RowCount = RowCount + 1
'End of if row > 2
End If
Next rw
End With
End Sub

Answer 1

This is the code I wrote for you. (Glad to see that so many others did, too. So you got a choice :-))
Sub TransscribeData()
' 25 Mar 2017
Dim WsS As Worksheet ' Source
Dim WsT As Worksheet ' Target
Dim TargetName As String
Dim LastRow As Long ' in WsS
Dim Rs As Long ' Source: row
Dim Rt As Long, Ct As Long ' Target: row / column
Dim Tmp As String
Dim Comp As String ' compare string
' Set Source sheet to the one containing the original data
Set WsS = Worksheets("BENEFIT Census")
LastRow = WsS.Cells(WsS.Rows.Count, NbcName).End(xlUp).Row
Application.ScreenUpdating = False
TargetName = "Benefits Census Formatted"
On Error Resume Next
Set WsT = Worksheets(TargetName) ' Set the Target sheet
If Err Then
' Create it if it doesn't exist
Set WsT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
WsT.Name = TargetName
' insert the column captions here
End If
On Error GoTo 0
Rt = WsT.Cells(WsS.Rows.Count, NfdName).End(xlUp).Row
AddMain WsS, WsT, NbcFirstDataRow, Rt ' Rt is counting in the sub
For Rs = NbcFirstDataRow To LastRow - 1
With WsS.Rows(Rs)
Tmp = .Cells(NbcFname).Value & .Cells(NbcName).Value & .Cells(NbcDob).Value
End With
With WsS.Rows(Rs + 1)
Comp = .Cells(NbcFname).Value & .Cells(NbcName).Value & .Cells(NbcDob).Value
End With
If StrComp(Tmp, Comp, vbTextCompare) Then
AddMain WsS, WsT, Rs + 1, Rt
Else
Ct = WsT.Cells(Rt, WsT.Columns.Count).End(xlToLeft).Column
If Ct > NfdMain Then Ct = Ct + 1
With WsS.Rows(Rs + 1)
WsT.Cells(Rt, Ct + NfdRelate).Value = .Cells(NbcRelate).Value
WsT.Cells(Rt, Ct + NfdDepName).Value = .Cells(NbcDepName).Value
End With
End If
Next Rs
Application.ScreenUpdating = True
End Sub
The above code calls one Sub routine which you must add in the same code module which, by the way, should be a normal code module (by default "Module1" but you can rename it to whatever).
Private Sub AddMain(WsS As Worksheet, WsT As Worksheet, _
Rs As Long, Rt As Long)
' 25 Mar 2017
Rt = Rt + 1
With WsS.Rows(Rs)
WsT.Cells(Rt, NfdFname).Value = .Cells(NbcFname).Value
WsT.Cells(Rt, NfdName).Value = .Cells(NbcName).Value
WsT.Cells(Rt, NfdDob).Value = .Cells(NbcDob).Value
WsT.Cells(Rt, NfdMain).Value = "Main"
End With
End Sub
Observe that I inserted the word "Main" as hard text. You could also copy the content of the appropriate call in the Source sheet. This procedure only writes the first entry. Dependents are written by another code.
The entire code is controlled by two "enums", enumerations, one for each of the worksheets. Enums are the quickest way to assign names to numbers. Please paste these two enums at the top of your code sheet, before either of the procedures.
Private Enum Nbc ' worksheet Benefit Census
NbcFirstDataRow = 2 ' Adjust as required
NbcFname = 1 ' columns:
NbcName
NbcDob
NbcRelate
NbcDepName
End Enum
Private Enum Nfd ' worksheet Formatted Data
NfdFirstDataRow = 2 ' Adjust as required
NfdName = 1 ' columns:
NfdFname
NfdDob
NfdMain
NfdRelate = 0 ' Offset from NfdMain
NfdDepName
End Enum
Note that the rule of enums is that you can assign any integer to them. If you don't assign any number the value will be one higher than the previous. So, NfdMain = 4, followed by NfdRelate which has an assigned value of 0, followed by NfdDepName which has a value of 0 + 1 = 1.
The numbers in these enumerations are columns (and rows). You can control the entire output by adjusting these numbers. For example, "Main" is written into column NfdMain (=4 =D). Change the value to 5 and "Main" will appear in column 5 = E. No need to go rummaging in the code. Consider this a control panel.
In the formatted output I introduced a logic which is slightly different from yours. If you don't like it you can change it easily by modifying the enums. My logic has the family name as the main criterion in the first column (switched from the raw data). In column D I write "Main". But when there is a dependent I write the relationship in column D. Therefore only entries without any dependents will have "Main" in that column. For your first example, the formatted row will show Rasmond / Shawn / 01-01-1990 / Spouse / Jessica, Child 1 / Vanessa.
If you wish to keep the "Main and place "Spouse" in the next column, just set the enum NfdRelate = 1. With the "control panel" it's that simple.

Answer 2

I would use an approach using Dictionaries to collect and organize the data, and then output it. Judging both by your comments, and the code, there is a lot of stuff you haven't included. But the following code will take your original data, and output a table close to what you show -- some of the results ordering is different, but it is standardized (i.e. there is a relation listed with every dependent name.
In the dictionary, we use Last Name and Birthdate as the "key" so as to combine what you stated were the duplicates.
We define two Class objects
Dependent object which includes the Name and the Relation
Family object which includes the First and Last Names, and Birthdate as well as a collection (dictionary) of the dependent objects.
Once we have it organized, it is relatively simple to output it as we want.
For a discussion of Classes, you can do an Internet search. I would recommend Chip Pearson's Introduction to Classes
Be sure to read the notes in the code about renaming the class modules, and also setting a reference to Microsoft Scripting Runtime
Class1
Option Explicit
'Rename this module: cDependents
'set reference to Microsoft Scripting Runtime
Private pRelation As String
Private pDepName As String
Public Property Get Relation() As String
Relation = pRelation
End Property
Public Property Let Relation(Value As String)
pRelation = Value
End Property
Public Property Get DepName() As String
DepName = pDepName
End Property
Public Property Let DepName(Value As String)
pDepName = Value
End Property
Class2
Option Explicit
'rename this module: cFamily
'set reference to Microsoft Scripting Runtime
Private pFirstName As String
Private pLastName As String
Private pBirthdate As Date
Private pDependents As Dictionary
Public Property Get FirstName() As String
FirstName = pFirstName
End Property
Public Property Let FirstName(Value As String)
pFirstName = Value
End Property
Public Property Get LastName() As String
LastName = pLastName
End Property
Public Property Let LastName(Value As String)
pLastName = Value
End Property
Public Property Get Birthdate() As Date
Birthdate = pBirthdate
End Property
Public Property Let Birthdate(Value As Date)
pBirthdate = Value
End Property
Public Function ADDDependents(Typ, Nme)
Dim cD As New cDependents
Dim sKey As String
With cD
.DepName = Nme
.Relation = Typ
sKey = .Relation & Chr(1) & .DepName
End With
If Not pDependents.Exists(sKey) Then
pDependents.Add Key:=sKey, Item:=cD
End If
End Function
Public Property Get Dependents() As Dictionary
Set Dependents = pDependents
End Property
Private Sub Class_Initialize()
Set pDependents = New Dictionary
End Sub
Regular Module
Option Explicit
'set reference to Microsoft Scripting Runtime
Sub Family()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim dF As Dictionary, cF As cFamily
Dim I As Long, J As Long
Dim sKey As String
Dim V As Variant, W As Variant
'Set source and results worksheets and results range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
'read source data into array
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=5)
End With
'Collect and organize the family and dependent objects
Set dF = New Dictionary
For I = 2 To UBound(vSrc, 1)
Set cF = New cFamily
With cF
.FirstName = vSrc(I, 1)
.LastName = vSrc(I, 2)
.Birthdate = vSrc(I, 3)
.ADDDependents vSrc(I, 4), vSrc(I, 5)
sKey = .LastName & Chr(1) & .Birthdate
If Not dF.Exists(sKey) Then
dF.Add Key:=sKey, Item:=cF
Else
dF(sKey).ADDDependents vSrc(I, 4), vSrc(I, 5)
End If
End With
Next I
'Results will have two columns for each relation, including Main
' + three columns at the beginning
'get number of extra columns
Dim ColCount As Long
For Each V In dF
I = dF(V).Dependents.Count
ColCount = IIf(I > ColCount, I, ColCount)
Next V
ColCount = ColCount * 2 + 3
ReDim vRes(0 To dF.Count, 1 To ColCount)
vRes(0, 1) = "First Name"
vRes(0, 2) = "Last Name"
vRes(0, 3) = "Birthdate"
vRes(0, 4) = "Dependant"
vRes(0, 5) = "Dependant Name"
For J = 6 To UBound(vRes, 2) Step 2
vRes(0, J) = "Relation " & J - 5
vRes(0, J + 1) = "Dependant Name"
Next J
I = 0
For Each V In dF
I = I + 1
With dF(V)
vRes(I, 1) = .FirstName
vRes(I, 2) = .LastName
vRes(I, 3) = .Birthdate
J = 2
For Each W In .Dependents
J = J + 2
With .Dependents(W)
vRes(I, J) = .Relation
vRes(I, J + 1) = .DepName
End With
Next W
End With
Next V
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Source Data
Results