Sub NamesData_v4()
'
'Prg : NamesData_v4
'Author : Markmzz
'Date : 07/10/2017
'Version: 04
'
'Define the variables explicitly
Dim LastRowL1 As Long, LastRowL2 As Long, LastColL1 As Long
Dim FirstColL2 As Long, RL1 As Long, RL2 As Long, CL1 As Long, CL2 As Long
Dim NCDL1 As Long, NCDL2 As Long, CGCDL2 As Long, LCL2 As Long, NGCDL2 As Long
Dim CurrentNameL2 As String
Dim myNewSheet As Worksheet, mySheet As Worksheet
Dim myArrayL1 As Variant, myArrayL2 As Variant
'Disable screen updating and activate the Data worksheet
Application.ScreenUpdating = False
Set mySheet = Worksheets("Data")
mySheet.Activate
'Determine the number of rows in the first list
LastRowL1 = Cells(Rows.Count, 1).End(xlUp).Row
'Determine the number of columns in the first list
LastColL1 = Cells(1, Columns.Count).End(xlToLeft).Column
'Determine the number of columns without the Name column in the first list
NCDL1 = LastColL1 - 1
'Sort, in ascending order, the first list
Range(Cells(2, 1), Cells(LastRowL1, LastColL1)).Sort _
Key1:=Range("A1"), _
Order1:=xlAscending
'Fill the first list array
myArrayL1 = Range(Cells(1, 1), Cells(LastRowL1, LastColL1))
'Set the first column of the second list
FirstColL2 = 1
'Create a new worksheet
Set myNewSheet = Sheets.Add
'Give the name of MergeData to the new worksheet
'If exist MergeData worksheet, delete it
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("MergeData").Delete
Application.DisplayAlerts = True
On Error GoTo 0
myNewSheet.Name = "MergeData"
'Create one sort list of unique names in the new worksheet (MergeData - list 2)
mySheet.Activate
Range(Cells(1, 1), Cells(LastRowL1, 1)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=myNewSheet.Range(Cells(1, 1).Address), _
Unique:=True
'Activate the worksheet MergeData
myNewSheet.Activate
'Determine the number of rows in the second list (MergeData worksheet)
LastRowL2 = Cells(Rows.Count, FirstColL2).End(xlUp).Row
'Determine the number of columns in the second list (without column Name)
ActiveSheet.Cells(1, 3).FormulaArray = _
"=Large(Countif(Data!$A$2:$A$" & LastRowL1 & "," & _
Range(Cells(1, FirstColL2), Cells(LastRowL2, FirstColL2)).Address & "),1)"
NCDL2 = (LastColL1 - 1) * Cells(1, 3).Value
ActiveSheet.Cells(1, 3).Clear
'Fill the second list array
myArrayL2 = Range(Cells(1, 1), Cells(LastRowL2, NCDL2 + 1)).Value
Range(Cells(1, 1), Cells(LastRowL2, NCDL2 + 1)).Clear
'Set one as the last column in the second list
LCL2 = 1
'Set two as the the current row in the first list
RL1 = 2
'Navigate by Names of the second list
For RL2 = 2 To LastRowL2
'Store the current Name of the second list
CurrentNameL2 = myArrayL2(RL2, FirstColL2)
'Define FirstColL2+1 with the current column in the second list
CL2 = FirstColL2 + 1
'Navigate by Names in the first list that are equal
'the current Name in the second list
Do While myArrayL1(RL1, 1) = CurrentNameL2
'Fill, in the second list, the data of the current name
For CL1 = 2 To LastColL1
myArrayL2(RL2, CL2) = myArrayL1(RL1, CL1)
'Add one to the counter of the current column in the second list
CL2 = CL2 + 1
Next CL1
'Add one to the counter of the current row in the first list
RL1 = RL1 + 1
'If the counter of the current row in the first list
'is greater than the total of rows in the first list, exit do
If RL1 > LastRowL1 Then Exit Do
Loop
Next RL2
'Determine the number of columns in group (Col2, Col3,...) in second List
NGCDL2 = NCDL2 / NCDL1
'Fill the data of the second list
Range(Cells(1, 1), Cells(LastRowL2, NCDL2 + 1)).Value = myArrayL2
'Fill the labels of columns of the second list
For CGCDL2 = 1 To NGCDL2
For CL1 = 2 To LastColL1
Cells(1, (CGCDL2 - 1) * NCDL1 + CL1).Value = _
myArrayL1(1, CL1) & "_" & CGCDL2
Next CL1
Next CGCDL2
'Autofit the columns of the second List
Cells(1, FirstColL2).CurrentRegion.EntireColumn.AutoFit
'Enable screen updating
Application.ScreenUpdating = True
End Sub
