Creating a payroll weekley summary sheet

mingandmong

Active Member
Joined
Oct 15, 2014
Messages
339
Hi I'm using excel 2016

i would like to create a weekly summary sheet totaling data from each daily worksheet, but only if they have worked during the week
So i have a workbook with tabs Sun-Sat the unique personnel number its in column A2 down (the unique number is not always in the same row on each sheet ie (A2 Sun but A20 on Mon)
i want to create the total sheet that automatically creates the personnel number in column A2 down but only once, and totals the data contained from column B,C,D,F,G,H,AK & AL

Thankyou very much
 

Some videos you may like

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
11,905
Office Version
2007
Platform
Windows
Use this

Change data in red with your information.

Code:
Sub weekley_summary()
    Dim days As Variant, sh2 As Worksheet, sh1 As Worksheet, d As Variant
    Dim f As Range, cols As Variant, r As Long, i As Long, c As Variant
    
    Set sh1 = Sheets("[COLOR=#ff0000]Total[/COLOR]")   'summary sheet
    days = Array([COLOR=#ff0000]"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"[/COLOR])
    cols = Array([COLOR=#ff0000]"B", "C", "D", "F", "G", "H", "AK", "AL"[/COLOR])
    
    sh1.Rows("2:" & Rows.Count).ClearContents
    For Each d In days
        Set sh2 = Sheets(d)
        For i = 2 To sh2.Range("A" & Rows.Count).End(xlUp).Row
            Set f = sh1.Range("A:A").Find(sh2.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
            If Not f Is Nothing Then
                r = f.Row
            Else
                r = sh1.Range("A" & Rows.Count).End(xlUp).Row + 1
                sh1.Range("A" & r).Value = sh2.Cells(i, "A").Value
            End If
            For Each c In cols
                sh1.Cells(r, c).Value = sh1.Cells(r, c).Value + sh2.Cells(i, c).Value
            Next
        Next
    Next
    MsgBox "End"
End Sub
 

mingandmong

Active Member
Joined
Oct 15, 2014
Messages
339
Hell DanteAmor
Thankyou for taking the time to create a solution, i just need it tweaking as it is about there
I just have 3 small issues

1) i forgot to mention i have data headers, on each sheet so the actual data starts in A3 ( i did try changing the A to A3 but no result)
2) can the data extracted from AK & AL be placed in the Total sheet in column I & J as it populates into AK & AL i have just temp hide the columns to make it look nicer
3) Employees who do not work as this is a template have zeros pre-populated so the summary sheet is including these who do not work i do have a solution and that is to delete all rows that do not have a value in column AK ( blank cell)

And once again thank you very much its not easy interpreting somebody else's ideas when reading
 

mingandmong

Active Member
Joined
Oct 15, 2014
Messages
339
Hi
I have resloved the issue of deletion, as the macro below deletes all rows if column Al contains a zero this works, i just need's to delete from row 3 as my first 2 rows have headers

[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Macro2()
'Modified 2/4/2019 1:05:28 PM EST
Application.ScreenUpdating = False
Dim Counter As Long
With Range("AL3", Range("AL" & Rows.Count).End(xlUp))
.AutoFilter Field:=1, Criteria1:=Array("0"), Operator:=xlFilterValues
Counter = .Columns(AL).SpecialCells(xlCellTypeVisible).Count
If Counter > 1 Then
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
.AutoFilter
End With
Application.ScreenUpdating = True
End Sub[/FONT]
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
11,905
Office Version
2007
Platform
Windows
Hi
I have resloved the issue of deletion, as the macro below deletes all rows if column Al contains a zero this works, i just need's to delete from row 3 as my first 2 rows have headers

[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Macro2()
'Modified 2/4/2019 1:05:28 PM EST
Application.ScreenUpdating = False
Dim Counter As Long
With Range("AL3", Range("AL" & Rows.Count).End(xlUp))
.AutoFilter Field:=1, Criteria1:=Array("0"), Operator:=xlFilterValues
Counter = .Columns(AL).SpecialCells(xlCellTypeVisible).Count
If Counter > 1 Then
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
.AutoFilter
End With
Application.ScreenUpdating = True
End Sub[/FONT]

Change 2 by 3:
Code:
sh1.Rows("3:" & Rows.Count).ClearContents
    For Each d In days
        Set sh2 = Sheets(d)
        For i = 3 To sh2.Range("A" & Rows.Count).End(xlUp).Row
 
Last edited:

mingandmong

Active Member
Joined
Oct 15, 2014
Messages
339
Hi DanteAmor
This new code has populated data from A3 down as my sheets have headers, this is working fine now
Thankyou very much
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
11,905
Office Version
2007
Platform
Windows
Im glad to help you, thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,099,978
Messages
5,471,792
Members
406,787
Latest member
abringley1083

This Week's Hot Topics

Top