Sub sorting()
' Create variables
Dim DocName As String ' name of excel file
Dim ThisBook As Workbook ' Current workbook
Dim s1 As Worksheet ' Sheet with raw data
Dim s2 As Worksheet ' Sheet with formatted data
Dim Lrow As Long ' Last row of raw data
Dim TP As Long ' For finding the total number of people
Dim CD As Long ' For holding the current number of dates for a person
Dim TD As Integer ' For finding the largest number of dates for anyone (this will determine the total number of columns used in sheet2)
Dim NR As Long ' Used for holding moving data from one array into the other
Dim Tog As Integer ' Toggle for whether matches are found
Dim NH As Long ' Used for holding a row number for later use
Dim DS1() As Variant ' Array used for holding and manipulating the data set
Dim DS2() As Variant ' Array used for holding and manipulating the data set
Dim Rdata As Range ' Range variable used to pull the raw data into the an Array and for the output of the formatted data
Dim CurPer As String ' Used for storing the name of the person currently being looked at
Dim CurD As Date ' used for storing the date currently being looked at for a person
Dim LoopNum1 As Long ' Used for outer loops
Dim LoopNum2 As Long ' Used for secondary loops
Dim LoopNum3 As Long ' Used for tertiary loops
' variables for turning a number into a column letter
Dim LastColumn As Long ' last column (as a number)
Dim FirstLetterAsNumber As Integer ' the number of the first letter of the column
Dim SecondLetterAsNumber As Integer ' the number of the second letter of the column
Dim ColumnString As String ' the column letter
' Set variables
DocName = ActiveWorkbook.Name
Set ThisBook = Workbooks(DocName)
Set s1 = ThisBook.Sheets("Sheet1")
Set s2 = ThisBook.Sheets("Sheet2")
Lrow = s1.Cells(s1.Rows.Count, "A").End(xlUp).Row
'Make sure a list exists
If Lrow < 2 Then
GoTo oops
End If
Set Rdata = s1.Range("A2:C" & Lrow)
ReDim DS1(1 To Lrow - 1, 1 To 3)
ReDim DS2(1 To Lrow - 1, 1 To 3)
DS1 = Rdata
TP = 0
TD = 0
CD = 0
NR = 1
' Combine enteries with same name and date
For LoopNum1 = LBound(DS1, 1) To UBound(DS1, 1)
If DS1(LoopNum1, 1) <> "" Then ' find next person
CurPer = DS1(LoopNum1, 1)
TP = TP + 1
CD = 0
For LoopNum2 = LBound(DS1, 1) To UBound(DS1, 1)
If DS1(LoopNum2, 1) = CurPer Then ' find all instances of a person
CurD = DS1(LoopNum2, 2)
Tog = 0
For LoopNum3 = LBound(DS1, 1) To UBound(DS1, 1)
If DS2(LoopNum3, 1) = CurPer And DS2(LoopNum3, 2) = CurD Then ' if person and date already exist on a list, then combine
DS2(LoopNum3, 3) = DS2(LoopNum3, 3) & "," & DS1(LoopNum2, 3)
DS1(LoopNum2, 1) = ""
Tog = 1
Exit For
End If
Next LoopNum3
If Tog = 0 Then ' if person and date do not exist on list, then add a new entery
CD = CD + 1
DS2(NR, 1) = DS1(LoopNum2, 1)
DS2(NR, 2) = DS1(LoopNum2, 2)
DS2(NR, 3) = DS1(LoopNum2, 3)
DS1(LoopNum2, 1) = ""
NR = NR + 1
End If
End If
Next LoopNum2
If CD > TD Then
TD = CD
End If
End If
Next LoopNum1
' combine all enteries of each person into a single line
ReDim DS1(1 To TP, 1 To (TD + 1))
NR = 0
For LoopNum1 = LBound(DS2, 1) To UBound(DS2, 1)
If DS2(LoopNum1, 1) <> "" Then ' look for the next person
NR = NR + 1
CurPer = DS2(LoopNum1, 1)
CD = 0
NH = LoopNum1
DS1(NR, 1) = CurPer
For LoopNum2 = LBound(DS2, 1) To UBound(DS2, 1)
If DS2(LoopNum2, 1) = CurPer Then ' find total number of entries (dates) for the person
CD = CD + 1
End If
Next LoopNum2
For LoopNum2 = CD To 1 Step -1
CurD = "1/1/1970"
For LoopNum3 = LBound(DS2, 1) To UBound(DS2, 1)
If DS2(LoopNum3, 1) = CurPer And DS2(LoopNum3, 2) > CurD Then ' find the entery with the highest date for the person
CurD = DS2(LoopNum3, 2)
NH = LoopNum3
End If
Next LoopNum3
DS1(NR, (LoopNum2 + 1)) = DS2(NH, 2) & " (" & DS2(NH, 3) & ")"
DS2(NH, 1) = ""
Next LoopNum2
End If
Next LoopNum1
' Put lisst in alphabetical order
ReDim DS2(1 To TP, 1 To (TD + 1))
NR = 1
NH = 0
For LoopNum1 = LBound(DS1, 1) To UBound(DS1, 1) ' one loop per person
For LoopNum2 = LBound(DS1, 1) To UBound(DS1, 1) ' find the name with the lowest value
If DS1(LoopNum2, 1) <> "" Then
If NH = 0 Or LCase(DS1(LoopNum2, 1)) < LCase(CurPer) Then
NH = LoopNum2
CurPer = DS1(LoopNum2, 1)
End If
End If
Next LoopNum2
For LoopNum2 = LBound(DS1, 2) To UBound(DS1, 2)
DS2(NR, LoopNum2) = DS1(NH, LoopNum2)
Next LoopNum2
DS1(NH, 1) = ""
NR = NR + 1
NH = 0
Next LoopNum1
' find the column number that corrisponds to Total number of date columns (TD) + 1 (for name)
' this uses some old code I wrote a while back
LastColumn = TD + 1
If LastColumn > 26 Then ' check if the Last Column is larger than Z
FirstLetterAsNumber = Int(LastColumn / 26) ' divide the total number of columns by 26 and remove the remainder
SecondLetterAsNumber = LastColumn - (FirstLetterAsNumber * 26) ' subtract the first number of columns used for the first letter
ColumnString = Chr(FirstLetterAsNumber + 64) & Chr(SecondLetterAsNumber + 64) ' use ASCII to change the numbers into letters and put them together
Else ' if the Last Column is smaller the Z
ColumnString = Chr(LastColumn + 64) ' use ASCII to change the column number into a letter
End If
'output formatted data to sheet2
Set Rdata = s2.Range("A1:" & ColumnString & TP)
Rdata = DS2
oops:
End Sub
