Unique values from multiple sheets

tezza

tezza

Active Member
Joined
Sep 10, 2006
Messages
375
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
  2. Web
Hi All

I've got a bit of a project going on here and may need a bit of help if possible please?

First bit, I would like to list all of the staff within the company based on multiple sheets of data as staff come and go so not all sheets are the exactsame.

Sheets labels
WK 1, WK 2, ...... WK 51, WK 52 (so week 1 to 52)

Cell A2 down lists staff employee numbers
Col B2 down lists staff names
Col C2 down shows total hours they worked that week

1) How would I go about creating a summary sheet that grabs both the unique staff number, name (together) and hours from all sheets then list everyone into the summary sheet once per emp num and name

2) Count how many times the above has appeared over the 52 weeks so I can work out pro-rata later on.

My list will then show each staff emp no, staff name, Weeks staff appears, total hours worked over 52 weeks, average hours worked (total hours/times appeared)

EG: (minus the ____ as they're just for spacing purpose here)

No:___Name__Appears___Sum of hours___Avg weekly hours
1234_Tezza______20___________500____________=500/20
Next unique staff.....

There are breaks between some of the sheets unfortunately so it'll have to search name specific but having numbers that increment will hopefully make it easier?

See what you think at least :)

Kind regards
Tezza
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not a pictures) of two of your sheets.
Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing'
and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary). Also, Please explain in detail what you mean by:
There are breaks between some of the sheets unfortunately so it'll have to search name specific but having numbers that increment will hopefully make it easier?
Click to expand...
 
Upvote 0
Try:
VBA Code: 
Sub CreateSummary()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, ws As Worksheet, v As Variant, dic As Object, i As Long, x As Long
    Set desWS = Sheets("Summary")
    Set dic = CreateObject("Scripting.Dictionary")
    For Each ws In Sheets
        If ws.Name <> "Summary" Then
            v = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value
            For i = 1 To UBound(v, 1)
                If Not dic.Exists(v(i, 1)) Then
                    dic.Add v(i, 1), Nothing
                    With desWS
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1) = v(i, 1)
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = v(i, 2)
                        .Cells(.Rows.Count, "C").End(xlUp).Offset(1) = .Cells(.Rows.Count, "C").End(xlUp).Offset(1) + v(i, 3)
                        .Cells(.Rows.Count, "D").End(xlUp).Offset(1) = 1
                        .Cells(.Rows.Count, "E").End(xlUp).Offset(1) = .Cells(.Rows.Count, "C").End(xlUp).Value / .Cells(.Rows.Count, "D").End(xlUp)
                    End With
                Else
                    With desWS
                        If Not IsError(Application.Match(v(i, 1), .Range("A:A"), 0)) Then
                            x = Application.Match(v(i, 1), .Range("A:A"), 0)
                            .Range("C" & x) = .Range("C" & x) + v(i, 3)
                            .Range("D" & x) = .Range("D" & x) + 1
                            .Range("E" & x) = .Range("C" & x) / .Range("D" & x)
                        End If
                    End With
                End If
            Next i
        End If
    Next ws
End Sub
 
Upvote 0
mumps said:
Try:
VBA Code: 
Sub CreateSummary()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, ws As Worksheet, v As Variant, dic As Object, i As Long, x As Long
    Set desWS = Sheets("Summary")
    Set dic = CreateObject("Scripting.Dictionary")
    For Each ws In Sheets
        If ws.Name <> "Summary" Then
            v = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value
            For i = 1 To UBound(v, 1)
                If Not dic.Exists(v(i, 1)) Then
                    dic.Add v(i, 1), Nothing
                    With desWS
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1) = v(i, 1)
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = v(i, 2)
                        .Cells(.Rows.Count, "C").End(xlUp).Offset(1) = .Cells(.Rows.Count, "C").End(xlUp).Offset(1) + v(i, 3)
                        .Cells(.Rows.Count, "D").End(xlUp).Offset(1) = 1
                        .Cells(.Rows.Count, "E").End(xlUp).Offset(1) = .Cells(.Rows.Count, "C").End(xlUp).Value / .Cells(.Rows.Count, "D").End(xlUp)
                    End With
                Else
                    With desWS
                        If Not IsError(Application.Match(v(i, 1), .Range("A:A"), 0)) Then
                            x = Application.Match(v(i, 1), .Range("A:A"), 0)
                            .Range("C" & x) = .Range("C" & x) + v(i, 3)
                            .Range("D" & x) = .Range("D" & x) + 1
                            .Range("E" & x) = .Range("C" & x) / .Range("D" & x)
                        End If
                    End With
                End If
            Next i
        End If
    Next ws
End Sub
Click to expand...
That was quick :)

Two small things, it adds an additional line of data with a blank name at the bottom each time you run it, and if you run it multiple times it adds to the list creating duplicates rather than recreating the list..

Is that something you could adjust please? Other than that it seems to run as I need it too :)
 
Upvote 0
Try:
VBA Code: 
Sub CreateSummary()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, ws As Worksheet, v As Variant, dic As Object, i As Long, x As Long
    Set desWS = Sheets("Summary")
    desWS.UsedRange.Offset(1).ClearContents
    Set dic = CreateObject("Scripting.Dictionary")
    For Each ws In Sheets
        If ws.Name Like "WK" & "*" Then
            v = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value
            For i = 1 To UBound(v, 1)
                If Not dic.Exists(v(i, 1)) Then
                    dic.Add v(i, 1), Nothing
                    With desWS
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1) = v(i, 1)
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = v(i, 2)
                        .Cells(.Rows.Count, "C").End(xlUp).Offset(1) = .Cells(.Rows.Count, "C").End(xlUp).Offset(1) + v(i, 3)
                        .Cells(.Rows.Count, "D").End(xlUp).Offset(1) = 1
                        .Cells(.Rows.Count, "E").End(xlUp).Offset(1) = .Cells(.Rows.Count, "C").End(xlUp).Value / .Cells(.Rows.Count, "D").End(xlUp)
                    End With
                Else
                    With desWS
                        If Not IsError(Application.Match(v(i, 1), .Range("A:A"), 0)) Then
                            x = Application.Match(v(i, 1), .Range("A:A"), 0)
                            .Range("C" & x) = .Range("C" & x) + v(i, 3)
                            .Range("D" & x) = .Range("D" & x) + 1
                            .Range("E" & x) = .Range("C" & x) / .Range("D" & x)
                        End If
                    End With
                End If
            Next i
        End If
    Next ws
End Sub
 
Upvote 0
mumps said:
Try:
VBA Code: 
Sub CreateSummary()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, ws As Worksheet, v As Variant, dic As Object, i As Long, x As Long
    Set desWS = Sheets("Summary")
    desWS.UsedRange.Offset(1).ClearContents
    Set dic = CreateObject("Scripting.Dictionary")
    For Each ws In Sheets
        If ws.Name Like "WK" & "*" Then
            v = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value
            For i = 1 To UBound(v, 1)
                If Not dic.Exists(v(i, 1)) Then
                    dic.Add v(i, 1), Nothing
                    With desWS
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1) = v(i, 1)
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = v(i, 2)
                        .Cells(.Rows.Count, "C").End(xlUp).Offset(1) = .Cells(.Rows.Count, "C").End(xlUp).Offset(1) + v(i, 3)
                        .Cells(.Rows.Count, "D").End(xlUp).Offset(1) = 1
                        .Cells(.Rows.Count, "E").End(xlUp).Offset(1) = .Cells(.Rows.Count, "C").End(xlUp).Value / .Cells(.Rows.Count, "D").End(xlUp)
                    End With
                Else
                    With desWS
                        If Not IsError(Application.Match(v(i, 1), .Range("A:A"), 0)) Then
                            x = Application.Match(v(i, 1), .Range("A:A"), 0)
                            .Range("C" & x) = .Range("C" & x) + v(i, 3)
                            .Range("D" & x) = .Range("D" & x) + 1
                            .Range("E" & x) = .Range("C" & x) / .Range("D" & x)
                        End If
                    End With
                End If
            Next i
        End If
    Next ws
End Sub
Click to expand...

Cooking on gas now :)

When I run it a second time the clear.contents appears to clear from row 3 and populates from row 3 also leaving row 2 always showing data.

Sorry, I meant to ask if it can be sorted by Col A please?

Thank you.
 
Upvote 0
Try this version. The line of code in red clears the contents from row 2 down to the last row regardless of how many times the macro is run. It works properly in the file you attached.
Rich (BB code): 
Sub CreateSummary()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, ws As Worksheet, v As Variant, dic As Object, i As Long, x As Long
    Set desWS = Sheets("Summary")
    desWS.UsedRange.Offset(1).ClearContents
    Set dic = CreateObject("Scripting.Dictionary")
    For Each ws In Sheets
        If ws.Name Like "WK" & "*" Then
            v = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value
            For i = 1 To UBound(v, 1)
                If Not dic.Exists(v(i, 1)) Then
                    dic.Add v(i, 1), Nothing
                    With desWS
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1) = v(i, 1)
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = v(i, 2)
                        .Cells(.Rows.Count, "C").End(xlUp).Offset(1) = v(i, 3)
                        .Cells(.Rows.Count, "D").End(xlUp).Offset(1) = 1
                        .Cells(.Rows.Count, "E").End(xlUp).Offset(1) = .Cells(.Rows.Count, "C").End(xlUp).Value / .Cells(.Rows.Count, "D").End(xlUp)
                    End With
                Else
                    With desWS
                        If Not IsError(Application.Match(v(i, 1), .Range("A:A"), 0)) Then
                            x = Application.Match(v(i, 1), .Range("A:A"), 0)
                            .Range("C" & x) = .Range("C" & x) + v(i, 3)
                            .Range("D" & x) = .Range("D" & x) + 1
                            .Range("E" & x) = .Range("C" & x) / .Range("D" & x)
                        End If
                    End With
                End If
            Next i
        End If
    Next ws
    desWS.Cells(1, 1).Sort Key1:=desWS.Columns(1), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
End Sub
 
Upvote 0
Solution
mumps said:
Try this version. The line of code in red clears the contents from row 2 down to the last row regardless of how many times the macro is run. It works properly in the file you attached.
Rich (BB code): 
Sub CreateSummary()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, ws As Worksheet, v As Variant, dic As Object, i As Long, x As Long
    Set desWS = Sheets("Summary")
    desWS.UsedRange.Offset(1).ClearContents
    Set dic = CreateObject("Scripting.Dictionary")
    For Each ws In Sheets
        If ws.Name Like "WK" & "*" Then
            v = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value
            For i = 1 To UBound(v, 1)
                If Not dic.Exists(v(i, 1)) Then
                    dic.Add v(i, 1), Nothing
                    With desWS
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1) = v(i, 1)
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = v(i, 2)
                        .Cells(.Rows.Count, "C").End(xlUp).Offset(1) = v(i, 3)
                        .Cells(.Rows.Count, "D").End(xlUp).Offset(1) = 1
                        .Cells(.Rows.Count, "E").End(xlUp).Offset(1) = .Cells(.Rows.Count, "C").End(xlUp).Value / .Cells(.Rows.Count, "D").End(xlUp)
                    End With
                Else
                    With desWS
                        If Not IsError(Application.Match(v(i, 1), .Range("A:A"), 0)) Then
                            x = Application.Match(v(i, 1), .Range("A:A"), 0)
                            .Range("C" & x) = .Range("C" & x) + v(i, 3)
                            .Range("D" & x) = .Range("D" & x) + 1
                            .Range("E" & x) = .Range("C" & x) / .Range("D" & x)
                        End If
                    End With
                End If
            Next i
        End If
    Next ws
    desWS.Cells(1, 1).Sort Key1:=desWS.Columns(1), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
End Sub
Click to expand...
Perfect, thank you ?

I just did a test on the backed up real sheet, is it possible to only delete the columns as far as Col G as I've got additional formulas that take this data beside it that continues doing other things with the data? That will be it then.
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
Applying dupicate Column Headers in an Excel Table
Replies
6
Views
394
awoohaw
awoohaw
H
  • Question
'How to' question about a Dashboard
Replies
5
Views
214
etaf
etaf
L
  • Question
Link and Lookup across Multiple Sheets/Tabs
Replies
2
Views
335
Herakles
H
D
  • Solved
Counting unique values across multiple cells...but utilizing color
Replies
5
Views
243
Eric W
Eric W
E
  • Question
Pull data from another sheet across weeks
Replies
0
Views
115
eechristaylor
E

Forum statistics

Threads
1,215,016
Messages
6,122,700
Members
449,092
Latest member
snoom82

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