Excel VBA splititng data into colums without duplicating - vba

Question

I'm trying to create a macro that goes through a huge list of data and that would split into columns parts of the data according to some criteria. Please not that there is no pattern that can be hard coded since in the example below the number of dependants can change drastically.
As of now, my data looks like this.
I would want it like this
I've written some code that goes through everything, and write each dependent on a new column but that create duplicates. I'm not able to detect whether that value was already on the row or not. Here is the code that I tried to write. Take not that we're already in the context of looping through every row.
dim isUnique
For i = 1 To 100
If not WsT.Cells(Rt, i).Value = .Cells(NbcDepfname).Value Then
isUnique = true
else
isUnique = false
End If
Next i
Ct = 10
If isUnique Then
WsT.Cells(Rt, Ct).Value = .Cells(NbcDepLname).Value
WsT.Cells(Rt, Ct + 1).Value = .Cells(NbcDepfname).Value
WsT.Cells(Rt, Ct + 2).Value = .Cells(NbcDepBDate).Value
End If
End With
I have very little experience with VBA and macros so my approach might not be the best or good at all. I've noticed also huge performance drops with that approach but it's alright for that project.
**EDIT ******
I understand my mistake perfectly. I'm looping through "EVERY" row of the first sheet with the unformatted data. I don't check correctly if the data is unique for that row before writing it, therefore, It will obviously keep writing a dependant per row. I tried with dictionaries but since it is possible that a dependant has both the same name and birthdate as another one on another row with different parents i couldn't keep that solution. The detection has to be done at the Row level.

Answer 1

Minor changes to the routine I posted in your previous, very similar thread, is all that is needed. That routine already uses dictionaries to check on duplicates, so it was merely a matter of adapting to your slightly different layout in this thread.
Of note, this requires, obviously, that the "Main" person be identified by a combination of FirstNameLastName + EmploymentDate. However, it does NOT require that the list be sorted.
It should adapt to any number of unique Dependent Name / BirthDate pairs.
It will Clear the entire Results worksheet before writing the results.
Be sure to read the notes in the different modules. They are critical to having it run. You will use two Class Modules and one Regular Module
Class 1
Option Explicit
'Rename this module: cDependents
'set reference to Microsoft Scripting Runtime
Private pBirthDt As Date
Private pDepName As String
Public Property Get BirthDt() As Date
BirthDt = pBirthDt
End Property
Public Property Let BirthDt(Value As Date)
pBirthDt = Value
End Property
Public Property Get DepName() As String
DepName = pDepName
End Property
Public Property Let DepName(Value As String)
pDepName = Value
End Property
Class 2
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 pEmploymentDate 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 Property Get EmploymentDate() As Date
EmploymentDate = pEmploymentDate
End Property
Public Property Let EmploymentDate(Value As Date)
pEmploymentDate = Value
End Property
Public Function ADDDependents(BrthDt, Name)
Dim cD As New cDependents
Dim sKey As String
With cD
.DepName = Name
.BirthDt = BrthDt
sKey = .BirthDt & 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
.LastName = vSrc(I, 1)
.FirstName = vSrc(I, 2)
.EmploymentDate = vSrc(I, 3)
.ADDDependents vSrc(I, 5), vSrc(I, 4)
sKey = .LastName & .FirstName & .EmploymentDate
If Not dF.Exists(sKey) Then
dF.Add Key:=sKey, Item:=cF
Else
dF(sKey).ADDDependents vSrc(I, 5), vSrc(I, 4)
End If
End With
Next I
'Results will have two columns for each relation
' + 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) = "Last Name"
vRes(0, 2) = "First Name"
vRes(0, 3) = "Employment Date"
For J = 4 To UBound(vRes, 2) Step 2
vRes(0, J) = "Dependent Name "
vRes(0, J + 1) = "Dependent BirthDate"
Next J
I = 0
For Each V In dF
I = I + 1
With dF(V)
vRes(I, 1) = .LastName
vRes(I, 2) = .FirstName
vRes(I, 3) = .EmploymentDate
J = 2
For Each W In .Dependents
J = J + 2
With .Dependents(W)
vRes(I, J) = .DepName
vRes(I, J + 1) = .BirthDt
End With
Next W
End With
Next V
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
With rRes
.Worksheet.Cells.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.Font.Color = vbWhite
.Interior.Color = vbBlue
.HorizontalAlignment = xlCenter
End With
For I = 3 To .Columns.Count - 1 Step 2
.Columns(I).NumberFormat = "yyyy-mm-dd"
Next I
.EntireColumn.AutoFit
End With
End Sub
Results when run on your data above

Answer 2

It occurred to me that you might have two dependents of the same name, spouse and child. Therefore I added another test to my previous solution to check the DoB. Here is the extended version.
Private Function IsUnique(ByVal DepName As String, _
DepDob As String, _
Ws As Worksheet, _
R As Long) As Boolean
' 11 Apr 2017
Dim Rng As Range
Dim Dob As Variant
Dim C As Long
With Ws.Rows(R)
Set Rng = Range(.Cells(NedDependt), .Cells(Ws.UsedRange.Columns.Count))
End With
DepName = Trim(DepName)
With Rng
For C = (.Cells.Count - 1) To 1 Step ((NedDepDob + 1) * -1)
If StrComp(Trim(.Cells(C).Value), DepName, vbTextCompare) = 0 Then
Dob = .Cells(C + NedDepDob).Value
If IsDate(Dob) Then
If IsDate(DepDob) Then
If CDate(Dob) = CDate(DepDob) Then Exit For
Else
If Trim(Dob) = Trim(DepDob) Then Exit For
End If
Else
If Trim(Dob) = Trim(DepDob) Then Exit For
End If
End If
Next C
End With
IsUnique = (C < 1)
End Function
For the purpose of this procedure I created a new enumeration which replaces the previous Enum Nfd. The new enum is adjusted to the actual columns as you published them above. You might need it not Private, if you refer to it in modules other than where it is located.
Private Enum Ned ' worksheet Employee Data
NedFirstDataRow = 2 ' Adjust as required
NedName = 1 ' columns:
NedFname
NedEmployed
NedDependt
NedDepName = 0 ' Offset from NedDependt
NedDepDob
End Enum
Below is the calling procedure I used for testing. Once you integrate the function into your project, the worksheet should be the one containing the formatted data while name, Dob and the row are variables.
Private Sub TestIsUnique()
Debug.Print IsUnique("vanessa", "1/12/1976", ActiveSheet, 9)
Debug.Print IsUnique("vanessa", "01/02/1976", ActiveSheet, 9)
End Sub
The date is a bit of a problem. I notice that you use yyyy/mm/ddd. The code will have no problem with that, but it may have a problem if the dates in your data are strings. I programmed it so that the code will first attempt to compare actual dates but will compare strings if one of the values can't be converted to a date.