VBA - find duplicates and extract summary data to new sheet

S

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
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Sort by date Sort by votes
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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!
 
Upvote 0
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:
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA: extract certain data from .txt file to new sheet
Replies
6
Views
602
st34lth
S
T
  • Question
Extracting information from multiple columns located in different workbooks to a specific worksheet in another workbook
Replies
0
Views
530
Tyjyt
T
D
  • Question
VBA - Split Source file-Find oldest date in column. Copy all rows with date to new sheet, Repeat on next oldest date. Also, remove some unwanted data.
Replies
0
Views
912
DK643
D
G
  • Question
Find Values that Match Criteria from Different Sheet and Copy over to Another
Replies
0
Views
133
glaccounting
G
Q
  • Solved
VBA Macro to Find Missing and Duplicate Data
2 3
Replies
20
Views
813
kevin9999
K

Forum statistics

Threads
1,214,656
Messages
6,120,762
Members
448,991
Latest member
Hanakoro

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