VBA Consolidation

J

jonnyp138

Board Regular
Joined
May 2, 2015
Messages
50
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
  6. 2011
  7. 2010
  8. 2007
  9. 2003 or older
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
Hi there, just wondering if someone can assist, basically I have a spreadsheet containing approx 150,000 lines of event information along with each time a note was added to that particular event ID, Here is an example of a small part of that table


<colgroup><col style="mso-width-source:userset;mso-width-alt:4059;width:83pt" width="111"> <col style="mso-width-source:userset;mso-width-alt:3108;width:64pt" width="85"> <col style="mso-width-source:userset;mso-width-alt:13019;width:267pt" width="356"> <col style="mso-width-source:userset;mso-width-alt:13641;width:280pt" width="373"> </colgroup><tbody>
[TD="class: xl66, width: 111"]Date[/TD]
[TD="class: xl67, width: 85"]Yes/No[/TD]
[TD="class: xl68, width: 356"]UUID[/TD]
[TD="class: xl69, width: 373"]Notes[/TD]

[TD="class: xl70, align: right"]22/07/2018 03:07[/TD]
[TD="class: xl71"]Y[/TD]
[TD="class: xl72"]10.220.34.177:3181.1531762471.11159[/TD]
[TD="class: xl73"]Auto Ticket: Event Closed adding worklog on Incident[/TD]

[TD="class: xl74, align: right"]22/07/2018 03:07[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11159[/TD]
[TD="class: xl77"]Auto Ticket: Incident requested for L3_SQL - PRIORITY_3[/TD]

[TD="class: xl74, align: right"]22/07/2018 22:08[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11163[/TD]
[TD="class: xl77"]Related Ticket Closed so Closing Event[/TD]

[TD="class: xl74, align: right"]22/07/2018 22:08[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11163[/TD]
[TD="class: xl77"]Auto Ticket: Incident requested for L3_SQL - PRIORITY_3[/TD]

[TD="class: xl70, align: right"]24/07/2018 10:08[/TD]
[TD="class: xl71"]Y[/TD]
[TD="class: xl72"]10.220.34.177:3181.1531762471.11235[/TD]
[TD="class: xl73"]Auto Ticket: Incident requested for L3_SQL - PRIORITY_3[/TD]

[TD="class: xl74, align: right"]24/07/2018 10:08[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11235[/TD]
[TD="class: xl77"]Related Ticket Closed so Closing Event[/TD]

[TD="class: xl70, align: right"]25/07/2018 07:23[/TD]
[TD="class: xl71"]Y[/TD]
[TD="class: xl72"]10.220.34.177:3181.1531762471.11255[/TD]
[TD="class: xl73"]Auto Ticket: Incident requested for L3_SQL - PRIORITY_3[/TD]

[TD="class: xl74, align: right"]29/07/2018 03:07[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11379[/TD]
[TD="class: xl77"]Related Ticket Closed so Closing Event[/TD]

[TD="class: xl74, align: right"]29/07/2018 03:07[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11379[/TD]
[TD="class: xl77"]Auto Ticket: Incident requested for L3_SQL - PRIORITY_3[/TD]

[TD="class: xl74, align: right"]29/07/2018 22:07[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11383[/TD]
[TD="class: xl77"]Auto Ticket: Incident requested for L3_SQL - PRIORITY_3[/TD]

[TD="class: xl78, align: right"]29/07/2018 22:07[/TD]
[TD="class: xl79"]Y[/TD]
[TD="class: xl80"]10.220.34.177:3181.1531762471.11383[/TD]
[TD="class: xl81"]Related Ticket Closed so Closing Event
[/TD]

</tbody>

As you can see there are duplicate UUID's on seperate lines as they have a different note added, what I would like to do is parse through the lines and amalgomate all duplicate event Id's with respective notes seperated by a pipe on the same line so it is like this:


<colgroup><col style="mso-width-source:userset;mso-width-alt:4059;width:83pt" width="111"> <col style="mso-width-source:userset;mso-width-alt:3108;width:64pt" width="85"> <col style="mso-width-source:userset;mso-width-alt:8557;width:176pt" width="234"> <col style="mso-width-source:userset;mso-width-alt:26075;width:535pt" width="713"> </colgroup><tbody>
[TD="class: xl66, width: 111"]Date[/TD]
[TD="class: xl67, width: 85"]Yes/No[/TD]
[TD="class: xl68, width: 234"]UUID[/TD]
[TD="class: xl69, width: 713"]Notes[/TD]

[TD="class: xl70, align: right"]22/07/2018 03:07[/TD]
[TD="class: xl71"]Y[/TD]
[TD="class: xl72"]10.220.34.177:3181.1531762471.11159[/TD]
[TD="class: xl73"]Auto Ticket: Event Closed adding worklog on Incident | Auto Ticket: Incident requested for L3_SQL - PRIORITY_3[/TD]

[TD="class: xl74, align: right"]22/07/2018 22:08[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11163[/TD]
[TD="class: xl77"]Related Ticket Closed so Closing Event | Auto Ticket: Incident requested for L3_SQL - PRIORITY_3[/TD]

[TD="class: xl74, align: right"]24/07/2018 10:08[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11235[/TD]
[TD="class: xl77"]Related Ticket Closed so Closing Event | Auto Ticket: Incident requested for L3_SQL - PRIORITY_3[/TD]

[TD="class: xl74, align: right"]29/07/2018 03:07[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11379[/TD]
[TD="class: xl77"]Related Ticket Closed so Closing Event | Auto Ticket: Incident requested for L3_SQL - PRIORITY_3[/TD]

[TD="class: xl74, align: right"]29/07/2018 22:07[/TD]
[TD="class: xl75"]Y[/TD]
[TD="class: xl76"]10.220.34.177:3181.1531762471.11383[/TD]
[TD="class: xl77"]Auto Ticket: Incident requested for L3_SQL - PRIORITY_3 | Related Ticket Closed so Closing Event[/TD]

</tbody>


Can anyone assist with the vba to acheive this?
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
Hey jonnyp138,

Try the below code VBA code ...

Code: 
Sub Consolidate_Notes()
Dim Ar1() As Variant, Ar2() As Variant, Cnt As Double, Ws As Worksheet
Set Ws = ActiveSheet
Set dic = CreateObject("Scripting.Dictionary")
Ar1 = Ws.Range("A1").CurrentRegion.Offset(1).Value
ReDim Ar2(1 To UBound(Ar1), 1 To UBound(Ar1, 2))
For x = LBound(Ar1) To UBound(Ar1)
    If Not dic.exists(Ar1(x, 3)) Then
        dic.Add Ar1(x, 3), Nothing
        Cnt = Cnt + 1
        For i = 1 To UBound(Ar1, 2)
            Ar2(Cnt, i) = Ar1(x, i)
        Next i
    Else
        For i = LBound(Ar2) To UBound(Ar2)
            If Ar2(i, 3) = Ar1(x, 3) Then Ar2(i, 4) = Ar2(i, 4) & " | " & Ar1(x, 4)
        Next i
    End If
Next x
With Sheets.Add(After:=Sheets(Sheets.Count))
    .Name = "Consolidated Notes"
    .Range("A1:D1") = Ws.Range("A1:D1").Value
    .Range("A2").Resize(UBound(Ar2, 1), UBound(Ar2, 2)) = Ar2
    .UsedRange.Columns.AutoFit
End With
End Sub
 
Upvote 0
Slight modification to the code to enhance the performance with large data sets

Rich (BB code): 
Sub Consolidate_Notes()
Dim Ar1() As Variant, Ar2() As Variant, Cnt As Double, Ws As Worksheet
Set Ws = ActiveSheet
Set dic = CreateObject("Scripting.Dictionary")
Ar1 = Ws.Range("A1").CurrentRegion.Offset(1).Value
ReDim Ar2(1 To UBound(Ar1), 1 To UBound(Ar1, 2))
For x = LBound(Ar1) To UBound(Ar1)
    If Not dic.exists(Ar1(x, 3)) Then
        dic.Add Ar1(x, 3), Nothing
        Cnt = Cnt + 1
        For i = 1 To UBound(Ar1, 2)
            Ar2(Cnt, i) = Ar1(x, i)
        Next i
    Else
        For i = LBound(Ar2) To UBound(Ar2)
            If Ar2(i, 3) = Ar1(x, 3) Then
                Ar2(i, 4) = Ar2(i, 4) & " | " & Ar1(x, 4)
                Exit For
            End If
        Next i
    End If
Next x
With Sheets.Add(After:=Sheets(Sheets.Count))
    .Name = "Consolidated Notes"
    .Range("A1:D1") = Ws.Range("A1:D1").Value
    .Range("A2").Resize(UBound(Ar2, 1), UBound(Ar2, 2)) = Ar2
    .UsedRange.Columns.AutoFit
End With
End Sub
 
Upvote 0
I was still unsatisfied with the performance & just noticed that since I have already used a dictionary why not utilize it more efficiently :D ... The below revised code should be significantly faster than the previous ones

Code: 
Sub Consolidate_Notes()
Dim Ar1() As Variant, Ar2() As Variant, Cnt As Double, Ws As Worksheet
Set Ws = ActiveSheet
Set dic = CreateObject("Scripting.Dictionary")
Ar1 = Ws.Range("A1").CurrentRegion.Offset(1).Value
ReDim Ar2(1 To UBound(Ar1), 1 To UBound(Ar1, 2))
For x = LBound(Ar1) To UBound(Ar1)
    If Not dic.exists(Ar1(x, 3)) Then
        Cnt = Cnt + 1
        dic.Add Ar1(x, 3), Cnt
        For i = 1 To UBound(Ar1, 2)
            Ar2(Cnt, i) = Ar1(x, i)
        Next i
    Else
        i = dic(Ar1(x, 3))
        Ar2(i, 4) = Ar2(i, 4) & " | " & Ar1(x, 4)
    End If
Next x
With Sheets.Add(After:=Sheets(Sheets.Count))
    .Name = "Consolidated Notes"
    .Range("A1:D1") = Ws.Range("A1:D1").Value
    .Range("A2").Resize(UBound(Ar2, 1), UBound(Ar2, 2)) = Ar2
    .UsedRange.Columns.AutoFit
End With
End Sub
 
Upvote 0
Thank you so much for the time and effort you have put in here I will try it out when back at work Monday and let you know
 
Upvote 0
This worked an absolute treat, thank you
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
Help Please
2 3
Replies
21
Views
405
Asbestos_Jen
Asbestos_Jen
S
  • Solved
Seperate Data In One Cell Across Multiple Cells
Replies
6
Views
2K
Alex Blakenburg
A
F
  • Question Question
Enhance simply subtract of date/times of time spent, to including indexing and subtracting time blocked from another table (with multiple criteria)
Replies
0
Views
387
freeb1893
F
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A
B
  • Question Question
Average Text In Pivot Table
Replies
2
Views
724
Bajan4eva1
B

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top