Hello
I've searched for other threads that could help me out, but I have not suceeded in finding a code that will help me out. I therefore turn to your help, hoping you can help me..
I've got a workbook for every department which is used to make a weekly status. Each of these workbooks contains a sheet with the 'weekly statuses over time', i.e. a table showing the weekly status for the department for week 1, week 2, week 3 etc.
I've attached the file to make it easier to understand what I'm talking about, see Weekly_Test.
Currently I can only see the performance of each department but I would like to be able to see the total performance for all departments, i.e. have a 'Total workbook' where all the weekly statuses are summed up weekly.
In the Weekly_Test file you can see the code which is used to generate the 'weekly status' sheets (also inserted at the end of this post). All workbooks for the departments are the same, apart from the file name which is the name of the department and this does not change.
The weekly status is generated in the following way:
In the sheet 'Indtastning' (data entry) you enter the data and the date. Then click 'Update'. The sheet is then copied to a new sheet with the date and all data is copied to the table in the 'his.status' sheet.
Now, I would like to add some code so that when I click 'Update' the data which is copied to the table in the 'his.status' sheet is also copied to a similar table in the 'Total' workbook.
Then when I make the weekly status for department 2, the data is also copied to the 'Total' workbook - but not in a separate table row, but added to the data from Department 1. Since the weekly status is done on the same weekday for all departments, the date should be used to tell the program where to copy the data to.
To solve this I've looked at threads about copying data to a closed workbook, however it seems that it is much faster (and easier) to make a code where the file is opened without it being shown on the screen.
My biggest challenge is how to tell the program to sum up the data from each department's weekly status in one table row, determined by the date.
Urgent help is needed - and very very much appreciated!
The code from the Weekly status:
Dim indtastArk
Dim arkDato
Public Sub Opdater()
arkDato = Cells(1, 1)
OpretDatoArk
' nulStilIndtastning
overførTilStatus
End Sub
Private Sub OpretDatoArk()
Sheets("Indtastning").Activate
With ActiveSheet
.Cells.Select
Selection.Copy
End With
ActiveWorkbook.Sheets.Add Before:=Sheets(4)
Sheets(4).Name = arkDato
Sheets(4).Activate
ActiveSheet.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Rem ændring af farve for indtastningsfelter
For Each cc In ActiveSheet.Range("A3:G26").Cells
If cc.Interior.ColorIndex = 6 Then
cc.Interior.ColorIndex = 20
End If
Next cc
ActiveSheet.Cells(1, 1).Select
End Sub
Private Sub nulStilIndtastning()
Set indtastArk = ActiveWorkbook.Sheets("Indtastning")
For Each cc In indtastArk.Range("A3:G29").Cells
If cc.Interior.ColorIndex = 6 Then
cc.ClearContents
End If
Next cc
End Sub
Private Sub CommandButton1_Click()
Opdater
End Sub
Private Sub overførTilStatus()
Dim næsteRæk, statusArk, aktuelleArk
Set statusArk = ThisWorkbook.Sheets(2)
Set aktuelleArk = ThisWorkbook.Sheets(4)
Rem Find første ledige række
With statusArk
For ræk = 3 To 65000
If .Cells(ræk, 1) = "" Then
næsteRæk = ræk
Exit For
End If
Next ræk
.Cells(næsteRæk, 1) = arkDato 'A - kol
.Cells(næsteRæk, 2) = aktuelleArk.Range("E4") 'B
.Cells(næsteRæk, 3) = aktuelleArk.Range("B4") 'C
.Cells(næsteRæk, 4) = aktuelleArk.Range("D3") 'D
.Cells(næsteRæk, 5) = aktuelleArk.Range("D4") 'E
.Cells(næsteRæk, 6) = aktuelleArk.Range("B12") 'F
.Cells(næsteRæk, 7) = aktuelleArk.Range("B15") 'G
.Cells(næsteRæk, 8) = "'" & (aktuelleArk.Range("C18") & _
"/" & aktuelleArk.Range("D18")) 'H
.Cells(næsteRæk, 9) = aktuelleArk.Range("B21") 'I
.Cells(næsteRæk, 10) = "'" & (aktuelleArk.Range("D21") & _
"/" & aktuelleArk.Range("E21")) 'J
.Cells(næsteRæk, 11) = aktuelleArk.Range("B24") 'K
.Cells(næsteRæk, 12) = "'" & (aktuelleArk.Range("B27") & _
"/" & aktuelleArk.Range("C27")) 'L
.Cells(næsteRæk, 13) = aktuelleArk.Range("E1") 'M
.Cells(næsteRæk, 14) = aktuelleArk.Range("F3") 'N
End With
End Sub
Display More