[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More
Experts Exchange Solution brought to you by
"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.
we dont have the upper limit .5 can be a good number for upper limit
Dim sws As Worksheet, dws As Worksheet
Dim slr As Long, dlr As Long
Dim sRng As Range, Cell As Range, oCell As Range
Dim Officer As String
Set sws = Sheets("sheet1")
Set dws = Sheets("Sheet2")
Application.ScreenUpdating = False
slr = sws.Cells(Rows.Count, 1).End(xlUp).Row
Set sRng = sws.Range("A2:A" & slr)
dws.Range("A1:B1").Value = Array("Source", "Offcier")
sws.AutoFilterMode = 0
For Each Cell In sRng
If Cell <> Source Then
Source = Cell
.AutoFilter field:=1, Criteria1:=Cell
If sws.Range("B1:B" & slr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
For Each oCell In sws.Range("B2:B" & slr).SpecialCells(xlCellTypeVisible)
If Officer = "" Then
Officer = oCell
Officer = Officer & "/" & oCell
dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row + 1
dws.Cells(dlr, "A") = Cell
dws.Cells(dlr, "B") = Officer
Officer = ""
sws.AutoFilterMode = 0
Application.ScreenUpdating = True
MsgBox "Finished.", vbInformation
Open in new window
Dim ParentDic As Object
Dim ChildDic As Object
Dim LastR As Long
Dim SourceArr As Variant
Dim Counter As Long
Dim SourceValue As Variant
Dim OfficerValue As Variant
Dim DestWs As Worksheet
Dim DestRow As Long
Const SourceWsName As String = "Source"
Set ParentDic = CreateObject("Scripting.Dictionary")
LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
SourceArr = .Range("a1:b" & LastR).Value
For Counter = 2 To LastR 'skip first row because it's just headers
SourceValue = SourceArr(Counter, 1)
OfficerValue = SourceArr(Counter, 2)
If ParentDic.Exists(SourceValue) Then
Set ChildDic = ParentDic.Item(SourceValue)
Set ChildDic = CreateObject("Scripting.Dictionary")
ParentDic.Add SourceValue, ChildDic
If Not ChildDic.Exists(OfficerValue) Then
ChildDic.Add OfficerValue, OfficerValue
SourceArr = ParentDic.Keys
Set DestWs = ThisWorkbook.Worksheets.Add
.Columns(1).NumberFormat = "@"
.Cells(1, 1) = "Source"
.Cells(1, 2) = "Officer"
DestRow = 2
For Counter = LBound(SourceArr) To UBound(SourceArr)
Set ChildDic = ParentDic.Item(SourceArr(Counter))
.Cells(DestRow, 1) = SourceArr(Counter)
.Cells(DestRow, 2) = Join(ChildDic.Keys, "/")
DestRow = DestRow + 1
Set ChildDic = Nothing
Set ParentDic = Nothing
Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.
From novice to tech pro — start learning today.
Premium members can enroll in this course at no extra cost.