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

DateYes/NoUUIDNotes
22/07/2018 03:07Y10.220.34.177:3181.1531762471.11159Auto Ticket: Event Closed adding worklog on Incident
22/07/2018 03:07Y10.220.34.177:3181.1531762471.11159Auto Ticket: Incident requested for L3_SQL - PRIORITY_3
22/07/2018 22:08Y10.220.34.177:3181.1531762471.11163Related Ticket Closed so Closing Event
22/07/2018 22:08Y10.220.34.177:3181.1531762471.11163Auto Ticket: Incident requested for L3_SQL - PRIORITY_3
24/07/2018 10:08Y10.220.34.177:3181.1531762471.11235Auto Ticket: Incident requested for L3_SQL - PRIORITY_3
24/07/2018 10:08Y10.220.34.177:3181.1531762471.11235Related Ticket Closed so Closing Event
25/07/2018 07:23Y10.220.34.177:3181.1531762471.11255Auto Ticket: Incident requested for L3_SQL - PRIORITY_3
29/07/2018 03:07Y10.220.34.177:3181.1531762471.11379Related Ticket Closed so Closing Event
29/07/2018 03:07Y10.220.34.177:3181.1531762471.11379Auto Ticket: Incident requested for L3_SQL - PRIORITY_3
29/07/2018 22:07Y10.220.34.177:3181.1531762471.11383Auto Ticket: Incident requested for L3_SQL - PRIORITY_3
29/07/2018 22:07Y10.220.34.177:3181.1531762471.11383Related Ticket Closed so Closing Event

<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>
</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:

DateYes/NoUUIDNotes
22/07/2018 03:07Y10.220.34.177:3181.1531762471.11159Auto Ticket: Event Closed adding worklog on Incident | Auto Ticket: Incident requested for L3_SQL - PRIORITY_3
22/07/2018 22:08Y10.220.34.177:3181.1531762471.11163Related Ticket Closed so Closing Event | Auto Ticket: Incident requested for L3_SQL - PRIORITY_3
24/07/2018 10:08Y10.220.34.177:3181.1531762471.11235Related Ticket Closed so Closing Event | Auto Ticket: Incident requested for L3_SQL - PRIORITY_3
29/07/2018 03:07Y10.220.34.177:3181.1531762471.11379Related Ticket Closed so Closing Event | Auto Ticket: Incident requested for L3_SQL - PRIORITY_3
29/07/2018 22:07Y10.220.34.177:3181.1531762471.11383Auto Ticket: Incident requested for L3_SQL - PRIORITY_3 | Related Ticket Closed so Closing Event

<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>
</tbody>


Can anyone assist with the vba to acheive this?
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
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

S
  • Solved
Seperate Data In One Cell Across Multiple Cells
Replies
6
Views
1K
Alex Blakenburg
A
F
  • 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
218
freeb1893
F
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
384
AndyEd
A
B
  • Question
Average Text In Pivot Table
Replies
2
Views
491
Bajan4eva1
B
K
  • Question
Auto Sort (Descinding) based on a column header using VBA
Replies
1
Views
86
Fluff
Fluff

Forum statistics

Threads
1,214,650
Messages
6,120,736
Members
448,988
Latest member
BB_Unlv

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