Szia!

A VB szerkesztőben a ThisWorkbook laphoz rendeltem egy makrót, ami a cellán állva duplaklikkre fix értékként beviszi az aktuális időt.
Ez csak akkor fog működni, ha minden lapon megszünteted a Bejelentkezés, és Kijelentkezés sorokban az érvényesítést.

Feltettem a módosított fájt, benne a hozzá tartozó mesével.
A füzetben rosszul írtam: nem az A:M, hanem az A:N tartomány adja a kimutatás alapját.
Az N oszlop FKERES függvénye az A oszlop ID-je alapján beírja a dolgozó nevét, ez szerepel a kimutatásban.

• A hozzászólás módosításra került: 4 years, 8 months telt el-delila. Indok: Javítás

Szívesen. Mi van a többi résszel?

Szia Imi!

Ugyanezeket az észrevételeket (dupla másolás, kettőspont hiánya) tettem én is a másik fórumon, ahova először feltette a kérdést Sutyi.

Üdv, Kati

Összeállítottam a másolat másolatát. Igaz, nem pont-, hanem vonal diagramot rajzoltam, de szerintem így jobban látszanak az értékek.
Az eredeti Munka1 lapról készítettem egy Másolat nevűt, ezt babráltam meg, és erről készítettem egy kimutatást a Kimutatás lapra, majd abból egy diagramot.

Szívesen.
Biztosan áttetted az OOQ1:OOQ4 tartományt egy közelebbi oszlopba. 🙂

Kicifráztam Titok adatait a 2. lapon.

Szívesen.
Írj a másik fórumra, mielőtt kitépik egymás haját! 😀

Kiegészítettem a makrót azzal, hogy ha a saját jelszavaddal lépsz be, minden lap látható legyen, és a lapvédelmet is levettem róluk.

Private Sub Workbook_Open()
    Dim lap As Integer, jelszo As String
    
    For lap = 2 To Sheets.Count 'lapok láthatóságának megszüntetése, védelme
        Sheets(lap).Protect Password:="SzuperTitkosJelszo"
        Sheets(lap).Visible = xlSheetVeryHidden
    Next
    
    'Jelszó bekérése
    jelszo = Application.InputBox("Kérem a jelszót", "Jelszó bekérése", , , , , , Type:=2)
    
    'Saját jelszavad esetén minden lap láthatóvá tétele, zárolás megszüntetése
    If jelszo = "Saját_jelszavam" Then
        For lap = 2 To Sheets.Count 'lapok láthatóvá tétele, védelem megszüntetése
            Sheets(lap).Unprotect Password:="SzuperTitkosJelszo"
            Sheets(lap).Visible = xlSheetVisible
        Next
    Else  'A jelszóhoz kötött munkalap meghatározása
        Select Case jelszo
            Case "jelszo_1": lap = 2
            Case "jelszo_2": lap = 3
            Case "jelszo_3": lap = 4
            Case "jelszo_4": lap = 5
            Case "jelszo_5": lap = 6
            Case "jelszo_6": lap = 7
            Case "jelszo_7": lap = 8
        End Select
        Sheets(lap).Visible = xlSheetVisible    'Az adott lap láthatóvá tétele
    End If
End Sub

„Ennyi kifizetés volt: „# ##0″ Ft”
Ügyelj a szóközökre!
A hivatkozás egyszerűen =A1

• A hozzászólás módosításra került: 5 years, 1 month telt el-delila.

Sub MM1()
    Dim lr As Long, r As Long
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    For r = lr To 2 Step -2
        If Range("A" & r) > Range("B" & r) Then
'            Range("A" & r & ":C" & r + 1).ClearContents
            Range("A" & r & ":C" & r + 1).Delete Shift:=xlUp
        End If
    Next r
End Sub

A Rows(r) az egész sort jelöli ki az állandók törlésére.

Sub MM1()
    Dim lr As Long, r As Long
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    For r = lr To 2 Step -1
        If Range("A" & r) > Range("B" & r) Then
            Range("A" & r & ":C" & r).ClearContents
'            Range("A" & r & ":C" & r).Delete Shift:=xlUp
        End If
    Next r
End Sub

A megjegyzésbe tett sor az A:C részt úgy törli az r sorból, hogy az alatta lévő cellákat feljebb viszi, míg a másik törli a tartalmat, és üresen maradnak a cellák.

Ha nem a ReDim a lényeg, akkor egyszerűbben is megoldható 1 ciklusban.

Sub mmm()
    Dim i As Integer
    For i = 1 To Sheets.Count - 1 'utolsó lap a Másol nevű
        Sheets(i).Cells(1, 3).Copy Sheets("Másol").Cells(i + 1, 1)
        Sheets("Másol").Cells(i + 1, 2) = Sheets(i).Name
    Next i
End Sub

nem próbáltam ki a ReDim-et. 🙂

Feltételezem, hogy csak 1 lapod van a füzetben, ezért nem indul sem a lapra lépés, sem a lap elhagyása esetén induló két makró.

Másold át a két makrót a VB szerkesztőben bal oldalon található ThisWorkbook laphoz (lapot kijelölöd, jobbra bemásolod). Az első makró első sorát (Private Sub Worksheet_Activate()) írd át Private Sub Workbook_Open() -re, a másodikét (Private Sub Worksheet_Deactivate()) pedig Private Sub Workbook_BeforeClose(Cancel As Boolean) -ra.

Az első a füzet megnyitásakor, a második pedig a bezáráskor indul automatikusan. Az eredeti, laphoz rendelt két makrót törölheted.

Szia!
Ezt makróval tudod megoldani. A lapfülön – ahol a tiltásokat be akarod vezetni – jobb klikk, Kód megjelenítése. Bejutottál a VB szerkesztőbe. Bal oldalon ki van jelölve a lap, ahonnan kiindultál, jobb oldalon egy üres felületet látsz. Oda másold be a lenti makrót. Mikor a füzetben rálépsz a lapodra, indul a makró, és letiltja a kivágás, másolás, beillesztés és vonszolás lehetőségét.

Private Sub Worksheet_Activate()
    Dim oCtrl As Office.CommandBarControl
    'CTRL+C, CTRL+V és CTRL+X letiltása
    Application.OnKey "^c", ""
    Application.OnKey "^x", ""
    Application.OnKey "^v", ""

    'Cut menü letiltása
    For Each oCtrl In Application.CommandBars.FindControls(ID:=21)
        oCtrl.Enabled = False
    Next oCtrl

    'Copy menü letiltása
    For Each oCtrl In Application.CommandBars.FindControls(ID:=19)
        oCtrl.Enabled = False
    Next oCtrl
    
    'Vonszolás letiltása
    Application.CellDragAndDrop = False
End Sub

Érdemes a lap elhagyásához bevinni a fentiek engedélyezését.

Private Sub Worksheet_Deactivate()
    Dim oCtrl As Office.CommandBarControl
    'CTRL+C, CTRL+V és CTRL+X engedélyezése
    Application.OnKey "^c"
    Application.OnKey "^x"
    Application.OnKey "^v"
    
    'Cut menü engedélyezése
    For Each oCtrl In Application.CommandBars.FindControls(ID:=21)
        oCtrl.Enabled = True
    Next oCtrl
        
    'Copy menü engedélyezése
    For Each oCtrl In Application.CommandBars.FindControls(ID:=19)
        oCtrl.Enabled = True
    Next oCtrl
           
    'Vonszolás engedélyezése
    Application.CellDragAndDrop = True
End Sub

A füzetet makróbarátként (xlsm kiterjesztéssel) kell mentened.

Nem a névkezelőben, hanem a szerkesztőléc bal oldalán adtam meg a nevet.

Jobb klikk a cellán, megjegyzés beszúrása.
Beállíthatod a karakter formátumát, majd szintén jobb klikkel a cellán megadhatod, hogy állandóan-, vagy csak az egérmutatónak a cella fölé vitelekor legyen látható a megjegyzés.
A megjegyzés dobozán jobb klikkre további beállítási lehetőségeket is kapsz a formátum beállításához, még képet is rendelhetsz hozzá.

Szívesen.
Végül mégis összejött.

Arra gondoltam, hogy a Q oszlopnál a lapvédelem beállítása előtt engedélyezni kell az oszlop kitöltését (Cellaformázás, Védelem fül, Zárolás négyzet elől kivesszük a pipát). Ezután a laphoz rendelt makró elvégzi a kitöltött Q zárolását.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 17 And Target <> "" Then
        'Engedélyezi a lapon a módosítást a MAKRÓ SZÁMÁRA
        ActiveSheet.Protect Password:="SzupertitkosJelszo", UserInterfaceOnly:=True
        
        Range(Target.Address).Locked = True
    End If
End Sub

A laphoz rendelt a makrót.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oszlop As String
    If Target.Column = 29 Then 'AC oszlop
        Select Case Target
            Case "Kezdés"
                oszlop = "AD"
            Case "Kész"
                oszlop = "AF"
            Case Else
                oszlop = "AE"
        End Select
        
        Application.EnableEvents = False
        Cells(Target.Row, oszlop) = Now
        Application.EnableEvents = True
    End If
End Sub

A Select Case utasításban a különböző beírható értékekhez megadtam, melyik oszlop legyen az időpont bevitele.

Szia!

Tedd egy ciklusba.

For lap=10 to sheets.count
   with sheets(lap)
      set oszlop1 = .Range("D93:E102,L93:M102,T93:U102")
      ...
   end with
next

Tanulmányozd Horváth Imre csodás leírását a többszintű legördülőkről. http://excel-bazis.hu/tutorial/tobbszintu-legordulo-lista-profi-megoldas
A megfelelő, zenét tartalmazó oszlop kiválasztása után makróval megszámoltatod, hány számot (sort) tartalmaz. Ennek megfelelően beíratod a hiperhivatkozások képleteit oda, ahova akarod, majd indítod a lejátszó ciklust.

Én is hallgatok zenét munka közben, de nem Excellel, hanem a jó öreg Winamp segítségével, amit erre fejlesztettek.

Az E oszlopban szóközzel kezdődik a települések neve, a Q1-ben nem.

Ha nem akarod az E oszlop szóközeit előre leszedni, akkor a képleted
=HAHIBA(FKERES(TRIM(E1);Q:R;2;0);"Nincs ilyen település")
Egyszerűbb, ha a trimmelést egy segédoszlopban végrehajtod. =TRIM(E1), ezt lemásolod a többi sorod mellé, majd a teljes oszlopot másolod, és az E1 cellába irányítottan, értékként beilleszted. A segédoszlop törölhető.
Ha előre elkészítetted ezt, a képletben a TRIM(E1) helyén marad az E1.

Egyszerűsítettem a makrón. A tömbbe eredetileg fordítva tettem be az adatokat (sor, oszlop).

Sub TombosMasolas()
    Dim Tomb(), sor As Long, usor As Long, oszlop As Integer, uoszlop As Integer, tombsor As Integer
    
    usor = Cells.SpecialCells(xlLastCell).Row
    uoszlop = Cells.SpecialCells(xlLastCell).Column

    ReDim Tomb(usor, uoszlop)
    tombsor = 0
    For sor = 2 To usor
        If Cells(sor, 2) = 4 Then
            tombsor = tombsor + 1
            For oszlop = 1 To uoszlop
                Tomb(oszlop, tombsor) = Cells(sor, oszlop)
            Next
        End If
    Next
    
    Sheets(2).Range("A1" & ":M" & uoszlop) = Application.Transpose(Tomb)
End Sub

Gondolom, a bevitt adatokat fel is akarod vinni a füzetbe, amit egy gombhoz rendelt makró visz véghez. Ezt a makrót kell az általad írt sorral kezdeni. Ha üres a textbox, a figyelmeztetés után ki is kell léptetni a Sub-ból, hogy ne rögzítse a hiányos adatokat.

If doboz="" Then
   Msgbox "Nem lehet üres a dobozszám"
   Exit Sub
End If

Szívesen.
Azért remélem, jön egy szebb megoldás is.

Szívesen.
A szövegfüggvényeket nézd meg a súgóban.

A második kérdésedről Horvát Imi már biztosan írt régebben, majd segít megtalálni a cikket. Szerintem abból jobban megérted majd, mintha én próbálkoznék vele.

Az elsőhöz írtam egy rövid makrót, amit a lapodhoz kell rendelned. Lapfülön jobb klikk, Kód megjelenítése. Ezzel bejutsz a VB szerkesztőbe. Bal oldalon az aktuális lapod lesz kijelölve, a jobb oldali üres területre másold a makrót.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 2 Then
        Application.EnableEvents = False
        If Target = "Kész" Then Cells(Target.Row, "D") = Now Else Cells(Target.Row, "C") = Now
        Application.EnableEvents = True
    End If
End Sub

Még annyit, hogy a B1, a C1 nem oszlopok, hanem cellák címei. Az oszlop B, vagy C.

Az alsó sort a B oszlopban kerested, de a dátumok a makró szerint a C-ben vannak. Lehet, hogy ezért nem kapsz eredményt.

Kicsit módosítva (C-re)

Sub popupuzenet()
    Dim sorszam As Integer
    Dim a As Integer
    Dim uzi As String
    
    With Worksheets("Munka1")
        sorszam = .Range("C" & Rows.Count).End(xlUp).Row
        For a = 5 To sorszam
            If .Range("C" & a) < Date + 7 Then
                uzi = uzi & .Range("C" & a) & vbLf
            End If
        Next a
    End With
    
    MsgBox uzi, , "Lejárt számlák"
End Sub

Szia!

Ha a kiinduló A2 cella fix, akkor

Sub keplet()
    Dim lRow As Integer

    Sheets("Munka1").Select
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    Cells(lRow + 1, 1) = "=SUMPRODUCT(1/COUNTIF(R2C1:R" & lRow & "C1,R2C1:R" & lRow & "C1))"
End Sub

Egyszerűbben is megoldhatod. Csak egy címke legyen, Label1. Ennek a magassága (Height) 3, szélessége (Width) nulla.

Private Sub UserForm_Activate()
    For i = 2 To 100 Step 2
        For j = 1 To 1000000: Next
        DoEvents
        UserForm1.Caption = i & "% komplett"
        Label1.Width = i * 2
    Next
End Sub

Egy példa:

Sub StatuszSor()
    Dim sor As Integer
    For sor = 1 To 25
        Application.StatusBar = sor & ". sor összege:   " & Cells(sor, 1) + Cells(sor, 2)
        Application.Wait Now + TimeValue("00:00:01")
    Next
    Application.StatusBar = False
End Sub

A For i Next i ciklust lezártad, de a For j-t nem.

Szia!

Próbáld így:

Sub pttro_1()
    Dim ciklus As Integer, usor As Long, ciklusszam As Integer
    
    ciklusszam = Range("I1")
    
    For ciklus = 1 To ciklusszam
        usor = Cells(ActiveCell.Row, ActiveCell.Column).End(xlDown).Row
        Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(usor, ActiveCell.Column)).Copy _
            Cells(usor + 1, ActiveCell.Column)
        Cells(usor + 1, ActiveCell.Column).Activate
    Next
    Application.CutCopyMode = False
End Sub

Itt az I1 cella tartalmazza az ismétlések számát. Ha ebbe a cellába beírt érték 3, akkor 3-szor fut le a ciklus, vagyis az eredetivel együtt összesen 4-szer szerepelnek majd egymás alatt az adataid.
Ha csak a megadott számban szeretnéd látni az adatokat, a
ciklusszam = Range("I1")
helyett írj
ciklusszam = Range("I1")-1 -et.

Üdv,
Kati

Szia Feri!

A Module2-be írtam egy makrót, benne némi magyarázattal.

Üdv, Kati

Én vagyok a hibás, tényleg rosszul írtam. Helyesen =B2*100/B1

%=érték*100/összeg
érték=141, összeg=602+141 –> 18,97712

Ellenőrzés: (602+141)*18,97712%
Számológépen: 602 plusz_gomb 141 =_gomb *_gomb 18,97712 %_gomb

Szia!
A másik fórumon, ahol feltetted ugyanezt a témát, válaszoltam.

Szívesen. 🙂

Kiteszel a lapodra egy alakzatot (négyszög, kör, miegyéb). Elnevezed Udvozlet-nek. Ennek az alakzatnak a képpel történő feltöltését végzi a makró a pillanatnyi idő függvényében.
A képeket az utvonal változóban megadott mappában kell tárolnod.

Most nem érek rá a magyarázatra, de biztosan rájössz.

Szarvas hiba részemről! Úgy akartam egy cellára állni, hogy előtte nem aktiváltam a lapot.

Private Sub Workbook_Open()
    Dim WS As Worksheet, sor As Long, valasz
    
    Set WS = Sheets("AKCIÓK")
    
    valasz = MsgBox("Töröljem a lejárt érvényességű tételeket?", vbYesNo + vbQuestion, "Törlési kérdés")
    If valasz = vbNo Then GoTo Raall
    
    With WS
        sor = 5
        Do While .Cells(sor, 1) <> ""
            If .Cells(sor, 2) < Date Then
                .Range("A" & sor & ":C" & sor).Delete Shift:=xlUp
            Else: sor = sor + 1
            End If
        Loop
        
        sor = 5
        Do While .Cells(sor, 5) <> ""
            If .Cells(sor, 6) < Date Then
                .Range("E" & sor & ":G" & sor).Delete Shift:=xlUp
            Else: sor = sor + 1
            End If
        Loop
    End With
    
Raall:
    Sheets("NYÍTÓOLDAL").Select
    Range("H5").Select
End Sub

Makró nélkül is megoldhatod. Kijelölöd a diagramon a teljes kört, majd az egyik cikket. Jobb klikk, Adatpont formázása, a Kitöltés menüpontnál beállítod a színt.

Igazad van, ez a kézenfekvő megoldás nem jutott eszembe.

A feltétel (If .Cells(5, 2) > „” Then) sem kell, elég ez:

        .Range("CH3:CO4").Copy
        .Range("B7:I28").PasteSpecial xlPasteFormats
        Application.CutCopyMode = False

Figyeld meg, hogy a másolandó formátumba a CH4:CO4 tartományt is be kell venni, hogy az alacsony sorok fekete háttere is másolódjon.

Szia!

A leírásodból nem derült ki, hogy melyik oszlopok adatait akarod töröltetni. Úgy gondolom, hogy a B:I tartományban lévőket.
Célszerű a füzet megnyitásakor eltüntetni a lejárt idejű bejegyzéseket, ezért az Open eseménybe érdemes betenni, a ThisWorkbook laphoz kell rendelni a makrót.

Private Sub Workbook_Open()
    Dim sor As Long, usor As Long
    
    sor = 5
    Do While Cells(sor, 2) <> ""
        If Cells(sor, 2) < Date Then
            Range("B" & sor & ":I" & sor + 1).Delete Shift:=xlUp
        Else
            sor = sor + 2
        End If
    Loop
End Sub

A Do-Loop ciklussal megyünk végig a B oszlop dátumain, az 5. sortól kezdve.
A Shift:=xlUp határozza meg a törlés irányát. Ha volt törlés, az alatta lévő adatok a törölt sor helyére ugranak fel, nem változtatjuk a sor változó értékét, ha nem volt, növeljük a sor értékét kettővel.
A ciklus addig fut, míg a B oszlopban talál adatot.

Krizsák László készített 5 éve egy vezérlő nélküli naptár userformot, amit egy fórumon közkinccsé tett.

Csatolom a füzetet, amiből átmásolhatjátok a saját fájljaitokba a Naptar userformot, a cmdClass modult, és a Munka1 laphoz rendelt eseményvezérelt makrót. Az én részem csupán a szombatok és vasárnapok színezése.

Meg kell nézni, van-e x nevű lap az osszes.xlsx-ben. Ha nics, létre kell hozni a Sheets.Add utasítással.

`On Error Resume Next
Set a = Sheets(„x”)
If Err.Number <> 0 Then
MsgBox „Nincs ilyen”
End If
On Error Goto 0

Szia!

Ezzel az a baj, hogy a gyűjtő füzet lapjain mindig csak az utoljára bemásolt füzet adatai lesznek meg. A meglévő adatokat a

WSO.Range("A2:BA100000").Delete

sor törli.
Másoláskor be kellene vinni egy üres oszlopba annak a fájlnak a nevét, ahonnan másolsz, és az új másolás előtt csak ezeket a sorokat kellene törölni. A tartományt megkeresheted a Match függvénnyel.

Szívesen 🙂

Örülök, hogy sikerült, és különösen annak, hogy önállóan javítottad a hibát!