Mrrrr's Forum (VIEW ONLY)
Un forum care ofera solutii pentru unele probleme legate in general de PC. Pe langa solutii, aici puteti gasi si alte lucruri interesante // A forum that offers solutions to some PC related issues. Besides these, here you can find more interesting stuff.
|
Lista Forumurilor Pe Tematici
|
Mrrrr's Forum (VIEW ONLY) | Reguli | Inregistrare | Login
POZE MRRRR'S FORUM (VIEW ONLY)
Nu sunteti logat.
|
Nou pe simpatie:
Profil simona2000
 | Femeie
25 ani
Galati
cauta Barbat
25 - 53 ani |
|
Mrrrr
AdMiN
 Inregistrat: acum 17 ani
Postari: 2186
|
|
This works for my existing file containing 1 sheet named activity-export, with column A for dates.
The code below extracts unique dates to a new sheet named INSUMAT (as in sheet activity-export the date repeats for each hourly measurement), then adds a SUMIF formula to sum up the values from activity-export sheet columns D:G to INSUMAT sheet columns B:E, then formats the table and readies it for printing.
Sub Adunare()
Dim sh As Worksheet
Dim ws, wsNew As Worksheet
Dim lRow, lRowNew As Long
Dim result, cell As Range
' If sheet with name INSUMAT exists, delete it without prompting
For Each sh In ActiveWorkbook.Worksheets
If sh.Name = "INSUMAT" Then
Application.DisplayAlerts = False
Worksheets("INSUMAT").Delete
Application.DisplayAlerts = True
End If
Next sh
' define sheet with data
Set ws = Worksheets("activity-export")
' add new sheet named INSUMAT
Set wsNew = Worksheets.Add(After:=ws)
wsNew.Name = "INSUMAT"
' find last row in data sheet
lRow = ws.Cells(Rows.Count, "A").End(xlUp).row
' copy unique values from data sheet to column A in the new sheet named INSUMAT
ws.Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsNew.Range("A1"), unique:=True
' set column widths & table headers for the new table in sheet INSUMAT
wsNew.Columns("A:E").ColumnWidth = 15
wsNew.Range("B1").FormulaR1C1 = "Pasi"
wsNew.Range("C1").FormulaR1C1 = "Durata (min)"
wsNew.Range("D1").FormulaR1C1 = "Distanta (m)"
wsNew.Range("E1").FormulaR1C1 = "Calorii (kcal)"
wsNew.Range("A1:E1").Font.Bold = True
wsNew.Range("A1:E1").HorizontalAlignment = xlCenter
wsNew.Range("A1:E1").VerticalAlignment = xlBottom
' find last row in sheet Insumat
lRowNew = wsNew.Cells(Rows.Count, "A").End(xlUp).row
' add formulas to sum numbers from data sheet in INSUMAT sheet
wsNew.Range("B2").FormulaLocal = "=SUMIF('activity-export'!$A$2:$A$1000;A2;'activity-export'!$D$2:$D$1000)"
wsNew.Range("B2").AutoFill destination:=Range("B2:B" & lRowNew)
wsNew.Range("C2").FormulaLocal = "=SUMIF('activity-export'!$A$2:$A$1000;A2;'activity-export'!$E$2:$E$1000)/60"
wsNew.Range("C2").AutoFill destination:=Range("C2:C" & lRowNew)
wsNew.Range("D2").FormulaLocal = "=SUMIF('activity-export'!$A$2:$A$1000;A2;'activity-export'!$F$2:$F$1000)"
wsNew.Range("D2").AutoFill destination:=Range("D2:D" & lRowNew)
wsNew.Range("E2").FormulaLocal = "=SUMIF('activity-export'!$A$2:$A$1000;A2;'activity-export'!$G$2:$G$1000)"
wsNew.Range("E2").AutoFill destination:=Range("E2:E" & lRowNew)
' set font sizes
wsNew.Range("A1:A" & lRowNew).Font.Size = 14
wsNew.Range("B1:B" & lRowNew).Font.Size = 14
wsNew.Range("C1:C" & lRowNew).Font.Size = 14
wsNew.Range("D1:D" & lRowNew).Font.Size = 14
wsNew.Range("E1:E" & lRowNew).Font.Size = 14
Set result = wsNew.Range("B2:E" & lRowNew)
With wsNew
For Each cell In result
cell.NumberFormat = "0.00"
cell.NumberFormat = "#,##0"
' cell.NumberFormat = "#,##0.00" 'activate for 2 decimals
Next cell
End With
' add borders to the entire table in sheet INSUMAT
With wsNew.UsedRange.Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
' show header on each page if printing
With wsNew.PageSetup
.PrintTitleRows = "$1:$1"
' .PrintTitleColumns = ""
End With
End Sub
|
_______________________________________
|
|
| pus acum 4 ani |
|