A lenti videóban egy időnyilvántartó táblázatot mutatok be, a megtakarított időt sebességmérő grafikonon megjelenítve. Ha kevés az időd és csak a videó érdekel, itt megtalálod.
Így néz ki a táblázat, melynek zöld celláit kell módosítanunk:
A munkafüzetben lévő munkalapok le vannak védve (kivéve a zöld cellákat) a makró által de nincs jelszó beállítva, így a lapok szükség esetén feloldhatóak.
Új sort hozzáadni illetve meglévő sort törölni a narancssárga gombokra történő kattintással lehet:
A sebességmérőt az alábbi gombra való kattintással tudjuk futtatni:
A sebességmérő (angolul speedometer) grafikon a táblázat “E” oszlopában lévő összes megtakarított időt jeleníti meg (a fenti képen ez az E5-ös cellában lévő 40). Attól függően, hogy hány percet takarítottunk meg (“E” oszlopban látható), a sebességmérőn más-más motivációs szöveg jelenik meg. Például 109 perc spórolásnál:
Az adott munkafüzetben nyissuk meg a Visual Basic szerkesztőjét (ALT + F11-gyel). Majd kattintsunk duplán arra a munkalap névre, melyhez a kódot hozzá szeretnénk adni (itt a lap neve: “Sheet2 (MegtakaritottIdo)”) és másoljuk bele:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
Dim Jelol As Range, Meddig 'Készítette: XLMotyo (https://xlmotyo.hu) Private Sub SpeedoMeter_Click() Dim Cella, i As Long, Elem 'sebességmérõ futtatása a "MegtakaritottIdo" munkalapon lévõ "Sebességmérõ futtatása" gomb megnyomása után ActiveSheet.Unprotect "" For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1 If Cells(i, 2) = "Idõ összesen" Then Elem = Cells(i, 5) 'megtakarított idõ Meddig = Cells(i, 5) / Cells(i, 3) 'idõmegtakarítás %-ban: megtakarított/eredeti Sheet3.Select Sleep 600 ActiveSheet.Unprotect "" Call Sebessegmeres(Meddig, Elem) ActiveSheet.Protect "" Exit For End If Next i Sheet2.Protect "" End Sub Sub AddNewRow_Click() Dim valodiUtolsoSor, UtolsoOszlop, i As Long 'új sor hozzáadása a "MegtakaritottIdo" munkalapon lévõ "Új sor hozzáadása" gomb megnyomása után Application.ScreenUpdating = False ActiveSheet.Unprotect "" 'összesítõ sor törlése: For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1 If Cells(i, 2) = "Idõ összesen" Then Cells(i, 2).EntireRow.Delete Exit For Next i 'utolsó sor azonosítása a használt tartományban (used range):: valodiUtolsoSor = Cells.Find("*", Cells(1, 1), xlFormulas, , xlByRows, xlPrevious).Row UtolsoOszlop = ActiveSheet.UsedRange.Columns.Count 'Cells.Find("*", Cells(1, 1), xlFormulas, , xlByRows, xlPrevious).Column 'összesítõ sor hozzáadása, képletekkel + szöveg félkövérré formázása: Cells(valodiUtolsoSor + 3, 1) = Application.UserName Cells(valodiUtolsoSor + 3, 2) = "Idõ összesen" Cells(valodiUtolsoSor + 3, 3) = "=SUM(C2:C" & (valodiUtolsoSor + 2) & ")" Cells(valodiUtolsoSor + 3, 4) = "=SUM(D2:D" & (valodiUtolsoSor + 2) & ")" Cells(valodiUtolsoSor + 3, 5) = "=SUM(E2:E" & (valodiUtolsoSor + 2) & ")" Range(Cells(valodiUtolsoSor + 3, 1), Cells(valodiUtolsoSor + 3, 5)).Font.Bold = True 'képletek hozzáadása az "E" oszlophoz: Cells(valodiUtolsoSor + 1, 1) = Application.UserName Cells(valodiUtolsoSor + 1, 5) = "=C" & (valodiUtolsoSor + 1) & "-D" & (valodiUtolsoSor + 1) 'szegély hozzáadása a használt tartományhoz (used range): With ActiveSheet.UsedRange .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlInsideVertical).LineStyle = xlContinuous .Borders(xlInsideHorizontal).LineStyle = xlContinuous End With 'narancs színû, vastag külsõ szegély hozzáadása az újonnan beszúrt sorhoz: Set Jelol = Range(Cells(valodiUtolsoSor + 1, 1).Address, Cells(valodiUtolsoSor + 1, UtolsoOszlop)) Call OrangeBorder 'szöveg vízszintesen középre helyezése a "D-F" oszlopoknál: With ActiveSheet.UsedRange .Columns(3).HorizontalAlignment = xlCenter .Columns(4).HorizontalAlignment = xlCenter .Columns(5).HorizontalAlignment = xlCenter .Columns(6).HorizontalAlignment = xlCenter End With 'zöld háttérszín hozzáadása az adatbeviteli oszlopokhoz (B, C, D, F, G): Range(Cells(2, 2).Address, Cells(valodiUtolsoSor + 1, 4).Address).Interior.Color = RGB(208, 223, 175) Range(Cells(2, 6).Address, Cells(valodiUtolsoSor + 1, 7).Address).Interior.Color = RGB(208, 223, 175) 'aktív munkalap ("MegtakaritottIdo") nem adatbeviteli celláinak levédése: ActiveSheet.UsedRange.Locked = False Range(Cells(1, 1).Address, Cells(1, UtolsoOszlop)).Locked = True Range(Cells(valodiUtolsoSor + 2, 1).Address, Cells(valodiUtolsoSor + 3, UtolsoOszlop)).Locked = True Range(Cells(valodiUtolsoSor + 3, 1).Address, Cells(valodiUtolsoSor + 3, UtolsoOszlop)).Locked = True ActiveSheet.UsedRange.Columns(1).Locked = True ActiveSheet.UsedRange.Columns(5).Locked = True ActiveSheet.UsedRange.Columns.AutoFit ActiveSheet.Protect "" Application.ScreenUpdating = True End Sub Private Sub DeleteRow_Click() Dim Valasz 'a munkalapon kijelölt sor törlése a "MegtakaritottIdo" munkalapon lévõ "Kiválasztott sor törlése" gomb megnyomása után 'Akkor is mûködik, ha a törölni kívánt sor egy celláját jelöljük ki Valasz = MsgBox("Kijelölted azt az egy sort melyet törölni akarsz?", vbYesNo + vbQuestion, "Válassz ki egy sort") If Valasz = vbNo Then Exit Sub Else 'vbYes ActiveSheet.Unprotect "" If ActiveSheet.UsedRange.Rows.Count > 1 Then Cells(ActiveCell.Row, 1).EntireRow.Delete ActiveSheet.UsedRange.Columns.AutoFit 'szegély hozzáadása a használt tartományhoz (used range): With ActiveSheet.UsedRange .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlInsideVertical).LineStyle = xlContinuous .Borders(xlInsideHorizontal).LineStyle = xlContinuous End With ActiveSheet.Protect "" End If End Sub Sub OrangeBorder() 'narancs színû, vastag külsõ szegély hozzáadása az újonnan beszúrt sorhoz: "Sub AddNewRow_Click" kódhoz kapcsolódóan With Jelol.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ThemeColor = 10 .TintAndShade = -0.249946592608417 .Weight = xlThick End With With Jelol.Borders(xlEdgeTop) .LineStyle = xlContinuous .ThemeColor = 10 .TintAndShade = -0.249946592608417 .Weight = xlThick End With With Jelol.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ThemeColor = 10 .TintAndShade = -0.249946592608417 .Weight = xlThick End With With Jelol.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 10 .TintAndShade = -0.249946592608417 .Weight = xlThick End With With Jelol.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlThin End With Jelol.Borders(xlInsideHorizontal).LineStyle = xlNone End Sub |
Az adott munkafüzetben nyissuk meg a Visual Basic szerkesztőjét (ALT + F11-gyel). Majd szúrjunk be egy modult és az alábbi kódot adjuk hozzá:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
Public Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long) Sub Sebessegmeres(Meddig, Elem) Dim i, j, k As Double, Sporolt 'Készítette: XLMotyo (https://xlmotyo.hu) 'a megtakarított idõ nem lehet negatív a "MegtakaritottIdo" munkalap "E" oszlopában: If Elem < 0 Then MsgBox "A megtakarított idõ nem lehet 0-nál kisebb. Menj vissza a 'MegtakaritottIdo' munkalapra " & vbNewLine & _ "ellenõrizd/javítsd a 'D' oszlopban lévõ értékeket a zöld celláknál (a 'D' oszlop értékei" & vbNewLine & _ "nem lehetnek nagyobbak, mint a 'C' oszlopé egy soron belül)!", vbExclamation, "Hiba" Sheet2.Select Sheet2.Columns("D").Select Exit Sub End If ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Shapes.Range(Array("TextBox 2")).Select Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "" Sheet3.Range("b6").Select 'szövegdoboz (text box) deaktiválása miatt kell Sheet3.Range("b6") = Elem / Meddig j = 0 'Mutato: indulo ertek k = 0 DoEvents For i = 0 To Meddig * 100 k = k + 1 Next i k = Elem / k 'k: 1-gyel novelem majd kiiratom For i = 0 To Meddig * 100 DoEvents j = j + k DoEvents Sheet3.Range("e2") = Format(j, "0") & " perc spórolás" DoEvents Sheet3.Range("f2") = i / 100 Next i Sporolt = Left(Sheet3.Range("e2"), Len(Sheet3.Range("e2")) - 14) 'pl.: "68 perc spórolás"-ból "68"-at kapunk '90-et és 180-at frissíteni ha szükséges: If Sporolt >= 0 And Sporolt < 90 Then 'ha a spórolt idõ nagyobb/egyenlõ mint 0 és kevesebb, mint 90 perc ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Shapes.Range(Array("TextBox 2")).Select Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Remek munka, iktass be egy kis szünetet!" ElseIf Sporolt > 90 And Sporolt <= 180 Then 'ha a spórolt idõ nagyobb mint 90 és kisebb/egyenlõ mint 180 perc ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Shapes.Range(Array("TextBox 2")).Select Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Szuper! Ma fejezd be a munkát korábban!" ElseIf Sporolt > 180 Then 'ha a spórolt idõ nagyobb, mint 180 perc ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Shapes.Range(Array("TextBox 2")).Select Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "A mindenit! Kérj fizetésemelést." End If End Sub |
Az időnyilvántartó működését az alábbi videóban ismertetem:
A sebességmérő grafikon létrehozását külön nem ismertetem, hiszen számos forrás elérhető erre vonatkozólag mind angolul, mind pedig magyarul. Ha azonban segítségre van szükséged, állok rendelkezésedre.
