String Like Data With VBA

Here is a script I wrote to help group like data (patients with multiple visits, customers with multiple orders, etc.) I hope you find this helpful.

If you are interested in any additional tools or consulting - please e-mail me at [email protected].

I had to replace the does not equal symbol (two opposing angled brackets) with @ in order to paste the code here. Otherwise you are good to copy and paste into VBA.

Sub Collate()
Dim A As Long
Dim B As Long
Dim c As String
Dim d As Long


Worksheets("Sheet1").Select

Columns("A:B").Select
ActiveSheet.Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlYes
ActiveWorkbook.Worksheets("String").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("String").Sort.SortFields.Add2 Key:=Range("A:A") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("String").Sort
.SetRange Range("A:B")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete

Columns("A:B").Select
ActiveSheet.Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlYes
ActiveWorkbook.Worksheets("String").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("String").Sort.SortFields.Add2 Key:=Range("B:B") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("String").Sort
.SetRange Range("A:B")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Columns("B:B").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete



d = 1

Do While Range("A" & d).Value @ ""
Range("A" & d).Value = WorksheetFunction.Trim(Range("A" & d).Value)
d = d + 1
Loop

d = 1
Do While Range("B" & d).Value @ ""
Range("B" & d).Value = WorksheetFunction.Trim(Range("B" & d).Value)
d = d + 1
Loop



Columns("A:B").Select
ActiveSheet.Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlYes
ActiveWorkbook.Worksheets("String").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("String").Sort.SortFields.Add2 Key:=Range("A:A") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("String").Sort
.SetRange Range("A:B")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


A = 2
B = 3
'make sure to add a character in D2 if you need to string
c = Range("D2").Value


Do While Range("A" & B).Value @ ""
Do While Range("A" & A).Value = Range("A" & B).Value
Range("B" & A).Value = Range("B" & A).Value & c & Range("B" & B)
B = B + 1
Loop
A = B
B = B + 1
Loop

Columns("A:B").Select
ActiveSheet.Range("A:B").RemoveDuplicates Columns:=Array(1), Header _
:=xlYes

End Sub