Results 1 to 9 of 9

Thread: VBA - find duplicates and extract summary data to new sheet

  1. #1
    New Member
    Join Date
    Aug 2019
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Question VBA - find duplicates and extract summary data to new sheet

    Hi all,

    I have used this forum to find answers for years and always found what I was looking for without even having to post my question. But this time I am stuck, proably because I don't knwo what exactly to search for.

    Let me explain what I am trying to achieve first:
    I am analysing employes expenses claims based on an extract I get out of our online expense portal. The aim here is to identify employees with multiple claims in a single week and summarise in a list who it is, how many lines (items) per claim and the total value of the claim. Below is an example extract from the source file. Column SHKZG defines what each row is, "S" is a line (item) and H is the total for a claim. and column WRBTR is the amount per line or claim. So employee one stayed in a hotel for 4 nights and paid 70 each night, and the total claim was 280.

    HED SGTXT SHKZG WRBTR
    1 530683 - EMPLOYEE ONE - HOTEL S 70
    1 530684 - EMPLOYEE ONE - HOTEL S 70
    1 530685 - EMPLOYEE ONE - HOTEL S 70
    1 530686 - EMPLOYEE ONE - HOTEL S 70
    1 115860 - EMPLOYEE ONE - TOTAL H 280
    1 531727 - EMPLOYEE TWO - HOTEL S 80
    1 531728 - EMPLOYEE TWO - DINNER YOU ONLY S 14.47
    1 531729 - EMPLOYEE TWO - MEALS - LUNCH (ATTENDEES) S 11.53
    1 531730 - EMPLOYEE TWO - MEALS - LUNCH (ATTENDEES) S 12.48
    1 531731 - EMPLOYEE TWO - MEALS - LUNCH (ATTENDEES) S 7.98
    1 531732 - EMPLOYEE TWO - BREAKFAST YOU ONLY S 1.49
    1 116041 - EMPLOYEE TWO - TOTAL H 127.95
    1 530928 - EMPLOYEE THREE - BUSINESS MILEAGE - PRIVATE CAR S 153
    1 530930 - EMPLOYEE THREE - HOTEL S 60
    1 115902 - EMPLOYEE THREE - TOTAL H 213
    1 530981 - EMPLOYEE FOUR - HOTEL S 67.5
    1 530983 - EMPLOYEE FOUR - HOTEL S 66
    1 530984 - EMPLOYEE FOUR - DINNER YOU ONLY S 15
    1 115905 - EMPLOYEE FOUR - TOTAL H 148.5
    1 531011 - EMPLOYEE FOUR - HOTEL S 67.5
    1 531012 - EMPLOYEE FOUR - DINNER YOU ONLY S 15.9
    1 531013 - EMPLOYEE FOUR - HOTEL S 67.5
    1 531014 - EMPLOYEE FOUR - DINNER YOU ONLY S 13.9
    1 115908 - EMPLOYEE FOUR - TOTAL H 164.8
    1 531016 - EMPLOYEE FOUR - HOTEL S 57.2
    1 531018 - EMPLOYEE FOUR - HOTEL S 57.21
    1 531019 - EMPLOYEE FOUR - DINNER YOU ONLY S 21.1
    1 115909 - EMPLOYEE FOUR - TOTAL H 135.51
    1 531021 - EMPLOYEE FOUR - HOTEL S 60
    1 531022 - EMPLOYEE FOUR - HOTEL BAR BILL S 2.2
    1 115910 - EMPLOYEE FOUR - TOTAL H 62.2
    1 530896 - EMPLOYEE FIVE - PARKING S 7.5
    1 115892 - EMPLOYEE FIVE - TOTAL H 7.5
    1 530897 - EMPLOYEE FIVE - PARKING S 13
    1 115893 - EMPLOYEE FIVE - TOTAL H 13
    1 530900 - EMPLOYEE FIVE - HOTEL S 50
    1 530901 - EMPLOYEE FIVE - MEALS - DINNER (ATTENDEES) S 17.25
    1 115894 - EMPLOYEE FIVE - TOTAL H 67.25
    1 530903 - EMPLOYEE FIVE - HOTEL S 91.2
    1 530904 - EMPLOYEE FIVE - PARKING S 7
    1 115896 - EMPLOYEE FIVE - TOTAL H 98.2


    I am trying to write a macro that would only extract employees that have more than one claim in each week and put it in a seperate tab in my workbook in below fashion.
    W/E Employee Lines of claim Amount of claim (exact)
    14/06/2019 EMPLOYEE FOUR 3 148.50
    14/06/2019 EMPLOYEE FOUR 4 164.80
    14/06/2019 EMPLOYEE FOUR 3 135.51
    14/06/2019 EMPLOYEE FOUR 2 62.20
    14/06/2019 EMPLOYEE FIVE 1 7.50
    14/06/2019 EMPLOYEE FIVE 1 13.00
    14/06/2019 EMPLOYEE FIVE 2 67.25
    14/06/2019 EMPLOYEE FIVE 2 98.20


    Apologies for the long post, I am completly stuck!

    thanks for any help you can give.

    Sophie

  2. #2
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,837
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

    Default Re: VBA - find duplicates and extract summary data to new sheet

    Try this for results starting "E1"
    NB:- Not sure where the date comes from.
    Code:
    Sub MG14Aug50
    Dim Rng As Range, Dn As Range, n As Long, txt As String, pRng As Range, R As Range, k As Variant, C As Long
    Set Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each Dn In Rng
    txt = Application.Index(Split(Dn.Value, " - "), 2)
        If Dn.Offset(, 1) = "S" Then
           If Not .Exists(txt) Then
                .Add txt, Dn
            Else
                Set .Item(txt) = Union(.Item(txt), Dn)
            End If
       End If
    Next
    Range("E1").Resize(, 4) = Array("W/E", "Employee", "Lines of claim", "Amount of claim")
    C = 1
    For Each k In .Keys
      For Each pRng In .Item(k).Areas
           C = C + 1
                Cells(C, "F") = k
                Cells(C, "G") = pRng.Count
                Cells(C, "H") = Application.Sum(pRng.Offset(, 2))
            
     Next pRng
    Next k
    End With
    
    End Sub
    Regards Mick

  3. #3
    New Member
    Join Date
    Aug 2019
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA - find duplicates and extract summary data to new sheet

    Hi Mick!

    thank you so much! this does most of what I needed

    forgot to mention where the date comes from, apologies for that... the date is stored in a seperate sheet names "Instructions" in a fixed cell "E9"

    I tried to amend your code to get the date in but get a syntax error below a copy of the code I amended...

    there are two more things I would love to achive if possible... I would like to keep a continuos list of these claims. How can I make sure that this posts the result at the end of existing entries? and also I want to remove the employees that only have one claim in the list so in this example the result should only return Employee 4 & 5 not the first 3 as they have only one claim on that date.

    Code:
    Sub TEST()
    
    Dim Rng As Range, Dn As Range, n As Long, txt As String, pRng As Range, R As Range, k As Variant, C As Long
    Sheets("Raw data Input").Select
    Set Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each Dn In Rng
    txt = Application.Index(Split(Dn.Value, " - "), 2)
        If Dn.Offset(, 1) = "S" Then
           If Not .Exists(txt) Then
                .Add txt, Dn
            Else
                Set .Item(txt) = Union(.Item(txt), Dn)
            End If
       End If
    Next
    Sheets("Details multiple claims").Select
    Range("A1").Resize(, 4) = Array("W/E", "Employee", "Lines of claim", "Amount of claim")
    C = 1
    For Each k In .Keys
      For Each pRng In .Item(k).Areas
           C = C + 1
                Cells(C, "A") = Sheets("Instructions").Range("E9").Copy Sheets("Details multiple claims").Destination:=Range("A2").End(xlDown)
                Cells(C, "B") = k
                Cells(C, "C") = pRng.Count
                Cells(C, "D") = Application.Sum(pRng.Offset(, 2))
            
     Next pRng
    Next k
    End With
    
    End Sub
    thank you so much for your help!

    Sophie

  4. #4
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,837
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

    Default Re: VBA - find duplicates and extract summary data to new sheet

    Try this:-
    Code:
    Sub MG15Aug56
    Dim Rng As Range, Dn As Range, n As Long, txt As String, pRng As Range
    Dim R As Range, k As Variant, C As Long, Lst As Integer, Dic As Object
    With Sheets("Raw Data Input")
        Set Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    End With
    
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    For Each Dn In Rng
    txt = Application.Index(Split(Dn.Value, " - "), 2)
        If Dn.Offset(, 1) = "S" Then
           If Not Dic.Exists(txt) Then
                Dic.Add txt, Dn
            Else
                Set Dic(txt) = Union(Dic(txt), Dn)
            End If
       End If
    Next
    
    With Sheets("Details multiple claims")
       .Range("A1").Resize(, 4) = Array("W/E", "Employee", "Lines of claim", "Amount of claim")
        Lst = .Range("A" & Rows.Count).End(xlUp).Row
        C = Lst
            For Each k In Dic.Keys
                  If Dic(k).Areas.Count > 1 Then
                        For Each pRng In Dic(k).Areas
                            C = C + 1
                            .Cells(C, "A") = Sheets("Instructions").Range("E9").Value
                            .Cells(C, "B") = k
                            .Cells(C, "C") = pRng.Count
                            .Cells(C, "D") = Application.Sum(pRng.Offset(, 2))
                        Next pRng
                  End If
            Next k
    With .Range("A1").Resize(C, 4)
        .Borders.Weight = 2
        .Columns.AutoFit
    End With
    
    End With
    
    End Sub
    Regards Mick

  5. #5
    New Member
    Join Date
    Aug 2019
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA - find duplicates and extract summary data to new sheet

    thank you so so much!

    This has done the trick

    Sophie

  6. #6
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,837
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

    Default Re: VBA - find duplicates and extract summary data to new sheet

    You're very welcome

  7. #7
    New Member
    Join Date
    Aug 2019
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA - find duplicates and extract summary data to new sheet

    Hi Mick,

    the macro worked for a few runs now but today I got an error ... runtime error '13' Type mismatch

    Code:
    ' Extract duplicate claim details       
        Dim Rng As Range, Dn As Range, n As Long, txt As String, pRng As Range
        Dim R As Range, k As Variant, C As Long, Lst As Integer, Dic As Object
        With Sheets("Raw data Input")
        Set Rng = .Range("I2", .Range("I" & Rows.Count).End(xlUp))
        End With
        
        Set Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
        For Each Dn In Rng
        txt = Application.Index(Split(Dn.Value, " - "), 2)
        If Dn.Offset(, 1) = "S" Then
        If Not Dic.Exists(txt) Then
        Dic.Add txt, Dn
        Else
        Set Dic(txt) = Union(Dic(txt), Dn)
        End If
        End If
        Next
        
        With Sheets("Details multiple claims").Range("A1").Resize(, 4) = Array("W/E", "Employee", "Lines of claim", "Amount of claim")
        Lst = .Range("A" & Rows.Count).End(xlUp).Row
        C = Lst
        For Each k In Dic.Keys
        If Dic(k).Areas.Count > 1 Then
        For Each pRng In Dic(k).Areas
        C = C + 1
        .Cells(C, "A") = Sheets("Instructions").Range("E9").Value
        .Cells(C, "B") = k
        .Cells(C, "C") = pRng.Count
        .Cells(C, "D") = Application.Sum(pRng.Offset(, 4))
        Next pRng
        End If
        Next k
        With .Range("A1").Resize(C, 4).Columns.AutoFit
        End With
        
        End With
    do you have any idea why???

    thank you!

  8. #8
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,837
    Post Thanks / Like
    Mentioned
    26 Post(s)
    Tagged
    12 Thread(s)

    Default Re: VBA - find duplicates and extract summary data to new sheet

    It look like the code has been altered slightly !!
    You have this:-
    Code:
    With Sheets("Details multiple claims").Range("A1").Resize(, 4) = Array("W/E", "Employee", "Lines of claim", "Amount of claim")
    It does not show very clearly here, but every thing after:- "With Sheets("Details multiple claims")
    should be on the next line

    It should be this :-
    Code:
    With Sheets("Details multiple claims")
        .Range("A1").Resize(, 4) = Array("W/E", "Employee", "Lines of claim", "Amount of claim")
    Last edited by MickG; Aug 22nd, 2019 at 06:53 AM.

  9. #9
    New Member
    Join Date
    Aug 2019
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA - find duplicates and extract summary data to new sheet

    Hi Mike,

    I made this change but am still getting an error. Using debug it is now higlighting this line:

    txt = Application.Index(Split(Dn.Value, " - "), 2)

    this is the amended code
    Code:
    ' Extract duplicate claim details       
        Dim Rng As Range, Dn As Range, n As Long, txt As String, pRng As Range
        Dim R As Range, k As Variant, C As Long, Lst As Integer, Dic As Object
        With Sheets("Raw data Input")
        Set Rng = .Range("I2", .Range("I" & Rows.Count).End(xlUp))
        End With
        
        Set Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
        For Each Dn In Rng
        txt = Application.Index(Split(Dn.Value, " - "), 2)
        If Dn.Offset(, 1) = "S" Then
        If Not Dic.Exists(txt) Then
        Dic.Add txt, Dn
        Else
        Set Dic(txt) = Union(Dic(txt), Dn)
        End If
        End If
        Next
        
        With Sheets("Details multiple claims")
            .Range("A1").Resize(, 4) = Array("W/E", "Employee", "Lines of claim", "Amount of claim")
        Lst = .Range("A" & Rows.Count).End(xlUp).Row
        C = Lst
        For Each k In Dic.Keys
        If Dic(k).Areas.Count > 1 Then
        For Each pRng In Dic(k).Areas
        C = C + 1
        .Cells(C, "A") = Sheets("Instructions").Range("E9").Value
        .Cells(C, "B") = k
        .Cells(C, "C") = pRng.Count
        .Cells(C, "D") = Application.Sum(pRng.Offset(, 4))
        Next pRng
        End If
        Next k
        With .Range("A1").Resize(C, 4).Columns.AutoFit
        End With
        
        End With

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •