I tried to write comparison in Excel macro for my work. Somehow, it is working not in the way I wanted the output. What I want is to compare the two columns and show the differences between them. If empty field on one column, the program should skip a line. Here is my code:
Sub run_compare_main()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim last_row As Integer
Dim input_array As Variant
Dim output_aray() As String
Dim a_counter As Integer
Dim b_counter As Integer
last_row = get_last_row("INPUT", "A")
ReDim output_array(1 To (last_row * 2), 1 To 5) '(last_row * 2)
input_array = Range("A7:D7" & (last_row * 2)).Value2
a_counter = 1
b_counter = 1
For i = 1 To (last_row * 2)
If input_array(a_counter, 1) = input_array(b_counter, 3) Then
output_array(i, 1) = input_array(a_counter, 1)
output_array(i, 2) = input_array(a_counter, 2)
output_array(i, 3) = input_array(b_counter, 3)
output_array(i, 4) = input_array(b_counter, 4)
a_counter = a_counter + 1
b_counter = b_counter + 1
ElseIf input_array(a_counter, 1) = input_array(a_counter - 1, 1) Then
output_array(i, 1) = input_array(a_counter, 1)
output_array(i, 2) = input_array(a_counter, 2)
a_counter = a_counter + 1
ElseIf input_array(b_counter, 3) = input_array(b_counter - 1, 3) Then
output_array(i, 3) = input_array(b_counter, 3)
output_array(i, 4) = input_array(b_counter, 4)
b_counter = b_counter + 1
End If
'find smaller value
If input_array(a_counter, 1) < input_array(b_counter, 3) Or input_array(b_counter, 1) = "" Then
output_array(i, 1) = input_array(a_counter, 1)
output_array(i, 2) = input_array(a_counter, 2)
a_counter = a_counter + 1
Else
output_array(i, 3) = input_array(b_counter, 3)
output_array(i, 4) = input_array(b_counter, 2)
b_counter = b_counter + 1
End If
If a_counter = last_row - 5 Or b_counter = last_row - 5 Then
Exit For
End If
Next
Call newtab("OUTPUT")
Range("A7").Resize(last_row, 4).Value = output_array
Sheets("INPUT").Range("A5:D6").Copy
Sheets("OUTPUT").Range("A5").Select
ActiveSheet.Paste
Columns("B:B").ColumnWidth = 80
Columns("D:D").ColumnWidth = 80
Dim LastCol As Long
Dim LastRow As Long
LastCol = ActiveSheet.UsedRange.Columns.Count
LastRow = ActiveSheet.UsedRange.Rows.Count
FilePath = "D:\Try\support.txt"
Open FilePath For Output As #2
CellData = ""
For i = 1 To LastRow
For j = 1 To LastCol
CellData = "The Value at location (" & i & "," & j & ") " & Trim(ActiveCell(i, j).Value)
Write #2, CellData
Next j
Next i
Close #2
MsgBox ("Job Done")
End Sub
Sub newtab(sheetname As String)
Application.DisplayAlerts = False
On Error Resume Next
Sheets(sheetname).Delete
Application.DisplayAlerts = True
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Activate
Sheets(Sheets.Count).Name = sheetname
End Sub
Function get_last_row(ByVal sheetname As String, column As String) As Integer
With Sheets(sheetname)
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow = .Cells.Find(What:="*", _
After:=.Range(column & "1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
get_last_row = LastRow
End Function
and here my worksample:
Related
Sub seivedata()
Dim Dsheet As Worksheet: Set Dsheet = ThisWorkbook.Sheets("Equipment Logon & Logoff Report")
Dim Osheet As Worksheet: Set Osheet = ThisWorkbook.Sheets("Analysis")
Dim onoff As Boolean
Dim arr As Variant
Call turnoffsettings(onoff = True)
MsgBox "starting transfer"
arr = Dsheet.Range("A1").CurrentRegion.Value
Dim i As Long, j As Long, row As Long
row = 2
For i = LBound(arr, 1) To UBound(arr, 1)
If i + 1 = UBound(arr, 1) Then End
If arr(i, 1) = arr(i + 1, 1) And arr(i, 2) = "LOGOFF" Then
For j = LBound(arr, 2) To UBound(arr, 2)
Osheet.Cells(row, 1).Value = arr(i, 1)
Osheet.Cells(row, 2).Value = DateValue(Format(arr(i, 3), "dd/mm/yyyy")) + TimeValue(Format(arr(i, 3), "hh:mm"))
Osheet.Cells(row, 3).Value = DateValue(Format(arr(i + 1, 3), "dd/mm/yyyy")) + TimeValue(Format(arr(i + 1, 3), "hh:mm"))
Osheet.Cells(row, 4).Value = WorksheetFunction.Text(Osheet.Cells(row, 3).Value - Osheet.Cells(row, 2).Value, "hh:mm")
Next j
row = row + 1
End If
Next i
Set arr = Nothing
MsgBox "completed transfer"
'Dim lrow As Long
'lrow = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).row
'Debug.Print lrow
'Osheet.Range("F2:F" & lrow).Value = Osheet.Range("A2:A" & lrow).Value
'Osheet.Range("F2:F" & lrow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
Call turnoffsettings(onoff = False)
End Sub
I created an excel spreadsheet with a macro. The code worked fine until the end user added a column. I then modified the code to account for the shift in columns. Everything worked except for the Data Range Object. I changed the Range to one column and now it is reading the column to the right of it.
They used to be columns A, B, I. They now read columns C, D, K. Has anyone had this problem before?
Here is my Macro Code as of now and after the new column:
Sub Transfer2NewWorkbook()
Dim currentsheet As String
Dim newsheet As String
Dim analysisDate As String
Dim initial As String
Dim aInitial() As String
Dim analystInit As String
Dim aBatch() As String
Dim batch As String
Dim batchNo As String
Dim key As Variant
Dim ikey As Variant
Dim SrowN As String
Dim rowN As Integer
Dim rowD As String
Dim mKey As String
Dim wb As Object
Dim dataRangeN As Range, dataRangeB As Range, dataRangeI As Range
Dim dataN As Object
Set dataN = CreateObject("Scripting.Dictionary")
Dim dataB As Object
Set dataB = CreateObject("Scripting.Dictionary")
Dim dataT As Object
Set dataT = CreateObject("Scripting.Dictionary")
Dim dataI As Object
Set dataI = CreateObject("Scripting.Dictionary")
Dim teststring As String
' Grab and Create filenames
currentsheet = ActiveWorkbook.Name
If Right$(currentsheet, 1) = "s" Then
currentsheet = Left(currentsheet, Len(currentsheet) - 4)
Else
currentsheet = Left(currentsheet, Len(currentsheet) - 5)
End If
newsheet = currentsheet & "-" & "uploadable"
' Grab data from original spreadsheet
analysisDate = ActiveWorkbook.Sheets(1).Cells(1, 10).Value
initial = ActiveWorkbook.Sheets(1).Cells(1, 3).Value
aInitial = Split(initial, "/")
analystInit = aInitial(1)
batch = ActiveWorkbook.Sheets(1).Cells(1, 5).Value
aBatch = Split(batch, ":")
batchNo = aBatch(1)
Set dataRangeN = Range("B:B")
Set dataRangeB = Range("C:C")
Set dataRangeI = Range("J:J")
For i = 4 To dataRangeB.Rows.Count
If Not IsEmpty(dataRangeB(i, 2)) Then
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 3).Value, "End") = 0 Then
Exit For
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i, 3).Value, "Blank") = 0 Then
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "Unseeded") = 0 Or StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "Seeded") = 0 Then
If Not IsEmpty(dataRangeI(i, 1)) Then
dataN.Add i, ActiveWorkbook.Sheets(1).Cells(i, 2).Value
dataB.Add i, ActiveWorkbook.Sheets(1).Cells(i, 3).Value
dataI.Add i, ActiveWorkbook.Sheets(1).Cells(i, 10).Value
End If
End If
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i, 3).Value, "Check") = 0 Then
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "Std") = 0 Then
If Not IsEmpty(dataRangeI(i, 1)) Then
dataN.Add i, ActiveWorkbook.Sheets(1).Cells(i, 2).Value
dataB.Add i, ActiveWorkbook.Sheets(1).Cells(i, 3).Value
dataI.Add i, ActiveWorkbook.Sheets(1).Cells(i, 10).Value
End If
End If
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i, 3).Value, "DUP") = 0 Then
rowD = dataB.Keys()(dataB.Count - 1)
If StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 2).Value, "CBOD") = 0 Then
dataN.Add rowD, "DUP-CBOD"
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 2).Value, "BOD") = 0 Then
dataN.Add rowD, "DUP-BOD"
End If
Else
If Len(ActiveWorkbook.Sheets(1).Cells(i, 3).Value) = 16 Then
dataT.Add i, ActiveWorkbook.Sheets(1).Cells(i + 1, 2).Value
dataB.Add i, ActiveWorkbook.Sheets(1).Cells(i, 3).Value
dataI.Add i, ActiveWorkbook.Sheets(1).Cells(i, 10).Value
End If
End If
Else
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "DUP") = 0 Then
If ActiveWorkbook.Sheets(1).Cells(i, 3).Value <> "" Then
rowD = dataB.Keys()(dataB.Count - 1)
If StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 2).Value, "CBOD") = 0 Then
dataN.Add rowD, "DUP-CBOD"
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 2).Value, "BOD") = 0 Then
dataN.Add rowD, "DUP-BOD"
End If
End If
End If
End If
Next i
' Open new spreadsheet
Set wb =
Workbooks.Add("\\******\ops\envcom\exec\envcom\LAB\BOD\uploadtemp.xlsx")
ActiveWorkbook.Sheets(1).Cells(2, 1).Value = analysisDate
ActiveWorkbook.Sheets(1).Cells(2, 2).Value = analystInit
ActiveWorkbook.Sheets(1).Cells(2, 4).Value = batchNo
rowN = 4
For Each key In dataB.Keys
mKey = key
If dataI.Exists(key) Then
SrowN = CStr(rowN)
If dataN.Exists(key) Or dataN.Exists(mKey) Then
If dataN(key) = "" Then
ActiveWorkbook.Sheets(1).Cells(SrowN, 1).Value = dataN(mKey)
Else
ActiveWorkbook.Sheets(1).Cells(SrowN, 1).Value = dataN(key)
End If
End If
ActiveWorkbook.Sheets(1).Cells(SrowN, 2).Value = dataB(key)
ActiveWorkbook.Sheets(1).Cells(SrowN, 3).Value = dataT(key)
ActiveWorkbook.Sheets(1).Cells(SrowN, 4).Value = dataI(key)
rowN = CInt(SrowN)
rowN = rowN + 1
End If
Next
ActiveWorkbook.SaveAs
("\\******\ops\envcom\exec\envcom\LAB\BOD\Uploadables\" & newsheet & ".xlsx")
End Sub
I am using these codes for text to row purpose but i am not able to convert it after certain Number of rows in Col B. whereas it is working fine for col c and d. one more thing if i am removing the on error resume next then i am getting subscript out of range error. please help me on these errors.
Expected Output for given input:
Code:
Sub Main()
On Error Resume Next
Columns("B:B").NumberFormat = "#"
Dim i As Long, c As Long, r As Range, v As Variant
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
v = Split(Range("B" & i), ",")
c = c + UBound(v) + 1
Next i
For i = 2 To c
Set r = Range("B" & i)
Dim arr As Variant
arr = Split(r, ",")
Dim j As Long
r = arr(0)
For j = 1 To UBound(arr)
Rows(r.Row + j & ":" & r.Row + j).Insert shift:=xlDown
r.Offset(j, 0) = arr(j)
r.Offset(j, -1) = r.Offset(0, -1)
r.Offset(j, 1) = r.Offset(0, 1)
Next j
Next i
Columns("C:C").NumberFormat = "#"
For i = 1 To Range("C" & Rows.Count).End(xlUp).Row
v = Split(Range("C" & i), ",")
c = c + UBound(v) + 1
Next i
For i = 2 To c
Set r = Range("C" & i)
arr = Split(r, ",")
r = arr(0)
For j = 1 To UBound(arr)
r.Offset(j, 0) = arr(j)
r.Offset(j, 1) = r.Offset(0, 1)
Next j
Next i
Columns("D:D").NumberFormat = "#"
For i = 1 To Range("D" & Rows.Count).End(xlUp).Row
v = Split(Range("D" & i), ",")
c = c + UBound(v) + 1
Next i
For i = 2 To c
Set r = Range("D" & i)
arr = Split(r, ",")
r = arr(0)
For j = 1 To UBound(arr)
r.Offset(j, 0) = arr(j)
r.Offset(j, 1) = r.Offset(0, 1)
Next j
Next i
Columns("E:E").NumberFormat = "#"
For i = 1 To Range("E" & Rows.Count).End(xlUp).Row
v = Split(Range("E" & i), ",")
c = c + UBound(v) + 1
Next i
For i = 2 To c
Set r = Range("E" & i)
arr = Split(r, ",")
r = arr(0)
For j = 1 To UBound(arr)
r.Offset(j, 0) = arr(j)
r.Offset(j, 1) = r.Offset(0, 1)
Next j
Next i
End Sub
Here is a code that works.
Before:
Inv Hours Bill am Loc
1 10,12 1,2 10,24 BANG,KOL
2 1,2,3 1,2,3 1,4,9 A,B,C
After:
Inv Hours Bill am Loc
1 10 1 10 BANG
1 12 2 24 KOL
2 1 1 1 A
2 2 2 4 B
2 3 3 9 C
Option Explicit
Sub Main()
Columns("B:B").NumberFormat = "#"
Dim i As Long, c As Long, r As Range, v As Variant
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
v = Split(Range("B" & i), ",")
c = c + UBound(v) + 1
Next i
For i = 2 To c
Set r = Range("B" & i)
Dim arr As Variant
arr = Split(r, ",")
Dim j As Long
r = arr(0)
For j = 1 To UBound(arr)
Rows(r.Row + j & ":" & r.Row + j).Insert shift:=xlDown
r.Offset(j, 0) = arr(j)
r.Offset(j, -1) = r.Offset(0, -1)
r.Offset(j, 1) = r.Offset(0, 1)
Next j
Next i
Columns("C:C").NumberFormat = "#"
For i = 1 To Range("C" & Rows.Count).End(xlUp).Row
v = Split(Range("C" & i), ",")
'c = c + UBound(v) + 1
Next i
For i = 2 To c
Set r = Range("C" & i)
arr = Split(r, ",")
r = arr(0)
For j = 1 To UBound(arr)
r.Offset(j, 0) = arr(j)
r.Offset(j, 1) = r.Offset(0, 1)
Next j
Next i
Columns("D:D").NumberFormat = "#"
For i = 1 To Range("D" & Rows.Count).End(xlUp).Row
v = Split(Range("D" & i), ",")
'c = c + UBound(v) + 1
Next i
For i = 2 To c
Set r = Range("D" & i)
arr = Split(r, ",")
r = arr(0)
For j = 1 To UBound(arr)
r.Offset(j, 0) = arr(j)
r.Offset(j, 1) = r.Offset(0, 1)
Next j
Next i
Columns("E:E").NumberFormat = "#"
For i = 1 To Range("E" & Rows.Count).End(xlUp).Row
v = Split(Range("E" & i), ",")
'c = c + UBound(v) + 1
Next i
For i = 2 To c
Set r = Range("E" & i)
arr = Split(r, ",")
r = arr(0)
For j = 1 To UBound(arr)
r.Offset(j, 0) = arr(j)
r.Offset(j, 1) = r.Offset(0, 1)
Next j
Next i
End Sub
So here is a code that works (reposted here as I guess you will close your other question):
Option Explicit
Sub SplitByRows()
Dim Col As Long, LastRow As Long, ColParts() As String
Dim i, a, k As Long
Dim StringNo As String
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRow
k = CountChrInString(Cells(i, 2).Value, ",")
StringNo = Cells(i, 1).Value
For a = 1 To k
Cells(i, 1).Value = Cells(i, 1).Value & "," & StringNo
Next a
Next i
For Col = 1 To 5 'Column A to Column C
ColParts = Split(Join(Application.Transpose(Range(Cells(2, Col), Cells(LastRow, Col))), ","), ",")
With Cells(2, Col).Resize(UBound(ColParts) + 1)
.NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(#_)"
.Value = Application.Transpose(ColParts)
End With
Next
End Sub
Public Function CountChrInString(Expression As String, Character As String) As Long
Dim iResult As Long
Dim sParts() As String
sParts = Split(Expression, Character)
iResult = UBound(sParts, 1)
If (iResult = -1) Then
iResult = 0
End If
CountChrInString = iResult
End Function
All I did was adding some "," to the first column as well at the beginning of your code.
For this I needed to count the amount of "," in the cell of the second column.
This was done with the function from this page: How to find Number of Occurences of Slash from a strings
After that your code just did the rest ;)
Sub ddf()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim x As Double
Dim y As Double
Do Until Range("a1").Value = ""
x = InStr(1, Range("a1"), ".")
y = InStr(1, Range("a1"), "?")
lr = Cells(Rows.Count, 1).End(xlUp).Row
If x > y Then
Range("a" & lr + 1).Formula = Left(Range("a1"), y)
Range("a1") = Replace(Range("a1"), Range("a" & lr + 1), "")
ElseIf x = 0 Then
Range("a" & lr + 1).Formula = Left(Range("a1"), y)
Range("a1") = Replace(Range("a1"), Range("a" & lr + 1), "")
ElseIf y = 0 Then
Range("a" & lr + 1).Formula = Left(Range("a1"), x - 1)
Range("a1") = Replace(Range("a1"), Left(Range("a1"), x), "")
Else
Range("a" & lr + 1).Formula = Left(Range("a1"), x - 1)
Range("a1") = Replace(Range("a1"), Left(Range("a1"), x), "")
End If
Loop
Exit Sub
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
In above code i want to loop the steps till range("a1") become blank. Please tell me where need corrections in above code.
Place
x = InStr(1, Sheets("sheet1").Range("a1"), ".")
y = InStr(1, Sheets("sheet1").Range("a1"), "?")
Also right before
Loop
And place both just after the last
End If
I want to be able to combine the rows for which the value in the first column matches, so that the values of non-blank cells are consolidated into one row. E.g.:
Mary Smith, A, [blank cell]
Mary Smith, [blank cell], B
-->
Mary Smith A B
I've tried to use the code below:
Dim RowNum As Long, LastRow As Long
Application.ScreenUpdating = False
RowNum = 4
LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
Range("A4", Cells(LastRow, 13)).Select
For Each Row In Selection
With Cells
If Cells(RowNum, 1) = Cells(RowNum + 1, 1) Then
Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 1)
Cells(RowNum + 1, 2).Copy Destination:=Cells(RowNum, 2)
Cells(RowNum + 1, 3).Copy Destination:=Cells(RowNum, 3)
Cells(RowNum + 1, 4).Copy Destination:=Cells(RowNum, 4)
Cells(RowNum + 1, 5).Copy Destination:=Cells(RowNum, 5)
Cells(RowNum + 1, 6).Copy Destination:=Cells(RowNum, 6)
Cells(RowNum + 1, 7).Copy Destination:=Cells(RowNum, 7)
Cells(RowNum + 1, 8).Copy Destination:=Cells(RowNum, 8)
Cells(RowNum + 1, 9).Copy Destination:=Cells(RowNum, 9)
Cells(RowNum + 1, 10).Copy Destination:=Cells(RowNum, 10)
Cells(RowNum + 1, 11).Copy Destination:=Cells(RowNum, 11)
Cells(RowNum + 1, 12).Copy Destination:=Cells(RowNum, 12)
Cells(RowNum + 1, 13).Copy Destination:=Cells(RowNum, 13)
Rows(RowNum + 1).EntireRow.Delete
End If
End With
RowNum = RowNum + 1
Next Row
Application.ScreenUpdating = True
'
End Sub
This does a fine job of consolidating the data so that there are only unique values in the first column, HOWEVER, when the row is copied up, the values of blank cells copy over populated cells, which NOT what I want. So for instance, running this macro on the above data would yield:
Mary Smith, A, [blank cell]
Mary Smith, [blank cell], B
-->
Mary Smith, A, [blank cell]
Any insight into how I might modify the above code (or use something more elegant) would be appreciated!!
This will do it very quickly:
Sub foo()
Dim ws As Worksheet
Dim lstrow As Long
Set ws = Sheets("Sheet1") ' Change to your sheet
With ws
lstrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("B4:M" & lstrow)
.Offset(, 26).FormulaR1C1 = "=IFERROR(INDEX(R4C[-26]:R" & lstrow & "C[-26],MATCH(1,INDEX((R4C1:R" & lstrow & "C1 = RC1)*(R4C[-26]:R" & lstrow & "C[-26] <>""""),),0)),"""")"
ws.Calculate
.Value = .Offset(, 26).Value
.Offset(, 26).ClearContents
End With
With .Range("A4:M" & lstrow)
.Value = .Value
.RemoveDuplicates 1, xlGuess
End With
End With
End Sub
It basically uses the formula: =INDEX(B$4:B$4,MATCH(1,INDEX(($A$4:$A$4 = $A4)*(B$4:B$4 <>""),),0)) To find all the values. Puts those formulas in blank columns and then copies the data back and removes the duplicates.
This will do all 13 columns at once.
It also does not care how many times the value in Column A is repeated. There could be 4 Mary Smiths in that column. It will grab the first value in each column and use that.
Before:
After:
Try the below code
Sub test()
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To LastRow
If ((Range("A" & i).Value = Range("A" & i + 1).Value) And (Range("B" & i).Value <> Range("B" & i + 1).Value) And ((Range("B" & i).Value = "") Or (Range("B" & i + 1).Value = "")) And (Range("C" & i).Value <> Range("C" & i + 1).Value) And ((Range("C" & i).Value = "") Or (Range("C" & i + 1).Value = ""))) Then
If Range("B" & i).Value = "" Then
Range("B" & i).Value = Range("B" & i + 1).Value
ElseIf Range("B" & i + 1).Value = "" Then
Range("B" & i + 1).Value = Range("B" & i).Value
End If
If Range("C" & i).Value = "" Then
Range("C" & i).Value = Range("C" & i + 1).Value
ElseIf Range("C" & i + 1).Value = "" Then
Range("C" & i + 1).Value = Range("C" & i).Value
End If
End If
Range("B" & i).EntireRow.Delete Shift:=(xlUp)
LastRow = LastRow - 1
Next i
End Sub
Here is another approach.
Create a Personnel object. Each Personnel object can have multiple attributes (the non blank column entries in your original table).
By using the Key property of the collection object, and using the Name (column1 data) as the key, we can detect duplicates without having to sort the original data. And the number of attributes for each name is limited only by the size of the worksheet.
Other information is in the comments.
Insert a class object and rename it cPersonnel
Below is the code for the Class and Regular modules
Class Module
Option Explicit
Private pName As String
Private pAttrib As String
Private pAttribs As Collection
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(Value As String)
pName = Value
End Property
Public Property Get Attrib() As String
Attrib = pAttrib
End Property
Public Property Let Attrib(Value As String)
pAttrib = Value
End Property
Public Property Get AttribS() As Collection
Set AttribS = pAttribs
End Property
Public Function ADDAttribS(Value As String)
pAttribs.Add Value
End Function
Private Sub Class_Initialize()
Set pAttribs = New Collection
End Sub
Regular Module
Option Explicit
Sub PersonnelAttribs()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim cP As cPersonnel, colP As Collection
Dim LastRow As Long, LastCol As Long
Dim I As Long, J As Long
'Set source and results worksheets, ranges
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
With wsSrc.Cells
LastRow = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastCol = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
End With
'Read source data into array
With wsSrc
vSrc = Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
'create and collect the Personnel objects
'Source data does not need to be sorted
Set colP = New Collection
On Error Resume Next
For I = 1 To UBound(vSrc, 1)
If Trim(vSrc(I, 1)) <> "" Then
Set cP = New cPersonnel
With cP
.Name = vSrc(I, 1)
For J = 2 To UBound(vSrc, 2)
If Trim(vSrc(I, J)) <> "" Then
.Attrib = Trim(vSrc(I, J))
.ADDAttribS .Attrib
End If
Next J
colP.Add cP, .Name
Select Case Err.Number
Case 457 'duplicate name
Err.Clear
For J = 1 To .AttribS.Count
colP(.Name).ADDAttribS .AttribS(J)
Next J
Case Is <> 0
Debug.Print Err.Number, Err.Description
Stop
End Select
End With
End If
Next I
On Error GoTo 0
'Create results array
'Number of columns
For I = 1 To colP.Count
With colP(I)
J = IIf(J > .AttribS.Count, J, .AttribS.Count)
End With
Next I
ReDim vRes(0 To colP.Count, 0 To J)
'Headers
vRes(0, 0) = "Name"
For J = 1 To UBound(vRes, 2)
vRes(0, J) = "Attrib " & J
Next J
'Populate data
For I = 1 To colP.Count
With colP(I)
vRes(I, 0) = .Name
For J = 1 To .AttribS.Count
vRes(I, J) = .AttribS(J)
Next J
End With
Next I
'Clear old data and write new
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2) + 1)
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Original Data
Results after Macro