VBA - find duplicates and extract summary data to new sheet

SophieF114

New Member
Joined
Aug 14, 2019
Messages
7
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.

HEDSGTXTSHKZGWRBTR
1530683 - EMPLOYEE ONE - HOTELS70
1530684 - EMPLOYEE ONE - HOTELS70
1530685 - EMPLOYEE ONE - HOTELS70
1530686 - EMPLOYEE ONE - HOTELS70
1115860 - EMPLOYEE ONE - TOTALH280
1531727 - EMPLOYEE TWO - HOTELS80
1531728 - EMPLOYEE TWO - DINNER YOU ONLYS14.47
1531729 - EMPLOYEE TWO - MEALS - LUNCH (ATTENDEES)S11.53
1531730 - EMPLOYEE TWO - MEALS - LUNCH (ATTENDEES)S12.48
1531731 - EMPLOYEE TWO - MEALS - LUNCH (ATTENDEES)S7.98
1531732 - EMPLOYEE TWO - BREAKFAST YOU ONLYS1.49
1116041 - EMPLOYEE TWO - TOTALH127.95
1530928 - EMPLOYEE THREE - BUSINESS MILEAGE - PRIVATE CARS153
1530930 - EMPLOYEE THREE - HOTELS60
1115902 - EMPLOYEE THREE - TOTALH213
1530981 - EMPLOYEE FOUR - HOTELS67.5
1530983 - EMPLOYEE FOUR - HOTELS66
1530984 - EMPLOYEE FOUR - DINNER YOU ONLYS15
1115905 - EMPLOYEE FOUR - TOTALH148.5
1531011 - EMPLOYEE FOUR - HOTELS67.5
1531012 - EMPLOYEE FOUR - DINNER YOU ONLYS15.9
1531013 - EMPLOYEE FOUR - HOTELS67.5
1531014 - EMPLOYEE FOUR - DINNER YOU ONLYS13.9
1115908 - EMPLOYEE FOUR - TOTALH164.8
1531016 - EMPLOYEE FOUR - HOTELS57.2
1531018 - EMPLOYEE FOUR - HOTELS57.21
1531019 - EMPLOYEE FOUR - DINNER YOU ONLYS21.1
1115909 - EMPLOYEE FOUR - TOTALH135.51
1531021 - EMPLOYEE FOUR - HOTELS60
1531022 - EMPLOYEE FOUR - HOTEL BAR BILLS2.2
1115910 - EMPLOYEE FOUR - TOTALH62.2
1530896 - EMPLOYEE FIVE - PARKINGS7.5
1115892 - EMPLOYEE FIVE - TOTALH7.5
1530897 - EMPLOYEE FIVE - PARKINGS13
1115893 - EMPLOYEE FIVE - TOTALH13
1530900 - EMPLOYEE FIVE - HOTELS50
1530901 - EMPLOYEE FIVE - MEALS - DINNER (ATTENDEES)S17.25
1115894 - EMPLOYEE FIVE - TOTALH67.25
1530903 - EMPLOYEE FIVE - HOTELS91.2
1530904 - EMPLOYEE FIVE - PARKINGS7
1115896 - EMPLOYEE FIVE - TOTALH98.2

<tbody>
</tbody>


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/EEmployeeLines of claimAmount of claim (exact)
14/06/2019EMPLOYEE FOUR3 £ 148.50
14/06/2019EMPLOYEE FOUR4 £ 164.80
14/06/2019EMPLOYEE FOUR3 £ 135.51
14/06/2019EMPLOYEE FOUR2 £ 62.20
14/06/2019EMPLOYEE FIVE1 £ 7.50
14/06/2019EMPLOYEE FIVE1 £ 13.00
14/06/2019EMPLOYEE FIVE2 £ 67.25
14/06/2019EMPLOYEE FIVE2 £ 98.20

<tbody>
</tbody>


Apologies for the long post, I am completly stuck!:confused::confused::confused:

thanks for any help you can give.

Sophie
 

Some videos you may like

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

MickG

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

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

SophieF114

New Member
Joined
Aug 14, 2019
Messages
7
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.

Rich (BB 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
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG15Aug56
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] pRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] R [COLOR="Navy"]As[/COLOR] Range, k [COLOR="Navy"]As[/COLOR] Variant, C [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]With[/COLOR] Sheets("Raw Data Input")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
txt = Application.Index(Split(Dn.Value, " - "), 2)
    [COLOR="Navy"]If[/COLOR] Dn.Offset(, 1) = "S" [COLOR="Navy"]Then[/COLOR]
       [COLOR="Navy"]If[/COLOR] Not Dic.Exists(txt) [COLOR="Navy"]Then[/COLOR]
            Dic.Add txt, Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic(txt) = Union(Dic(txt), Dn)
        [COLOR="Navy"]End[/COLOR] If
   [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]With[/COLOR] 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
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
              [COLOR="Navy"]If[/COLOR] Dic(k).Areas.Count > 1 [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] pRng [COLOR="Navy"]In[/COLOR] 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))
                    [COLOR="Navy"]Next[/COLOR] pRng
              [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]With[/COLOR] .Range("A1").Resize(C, 4)
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

SophieF114

New Member
Joined
Aug 14, 2019
Messages
7

ADVERTISEMENT

thank you so so much!

This has done the trick :)

Sophie
 

SophieF114

New Member
Joined
Aug 14, 2019
Messages
7

ADVERTISEMENT

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!
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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:

SophieF114

New Member
Joined
Aug 14, 2019
Messages
7
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
Rich (BB 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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,355
Messages
5,624,207
Members
416,017
Latest member
moritz210

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
Top