Ott választásról volt szó, nem sorsolásról

Mekkora számok kellenek, és mi az elrendezés?
A nevek esetleg külön-külön lapon vannak, vagy mindegyik egymás alatt valamelyik oszlopban 1 lapon? A kigyűjtés 1 lapra, vagy esetleg mindenkinek a saját lapjára történjen?

Pardon, csak becsomagolva lehet csatolni a makrós füzetet.

Szia!

A lapon, ahova beviszed az értékeket, az A:D oszlop ne legyen zárolt. Védd le a lapot. Nálam a „SzuperTitkosJelszó”-védi a lapot.
Másold be a makrót egy modulba, majd tegyél ki hozzá egy gombot. Az aktuális sor A:D tartományát másolja a Munka2 lap első üres sorába. Ha van, ha nincs fejléc a Munka2-n, az első másolat a 2. sorba kerül (üres lap esetén).
Másolás után a kiinduló munkalap kitöltött sora nem írható felül, zároltak lesznek a cellák.

Sub Masolas()
    Dim ide As Long
    
    ActiveSheet.Protect Password:="SzuperTitkosJelszó", UserInterfaceOnly:=True
    ide = Sheets("Munka2").Range("A" & Rows.Count).End(xlUp).Row + 1

    Range("A" & Selection.Row & ":D" & Selection.Row).Copy _
        Sheets("Munka2").Range("A" & ide)
    Range("A" & Selection.Row & ":D" & Selection.Row).Locked = True
End Sub

Szívesen. 🙂

Erre gondoltál?

Kicsit rövidebbre vettem a Munka2!A4 cella képletét, ami alapján a többit is módosíthatod. A feltételnél nincs szükség a HAHIBA függvényre.

=HA(INDEX(Táblázat1;HOL.VAN($H$1;Munka1!$L:$L;0)-1;OSZLOP()+2)=0;"";HAHIBA(INDEX(Táblázat1;HOL.VAN($H$1;Munka1!$L:$L;0)-1;OSZLOP()+2);""))

Az ÜRES függvényt Te juttattad eszembe.
Elég kacifántosra sikerült, hátha kapsz egyszerűbb megoldást. Az ilyen tengerikígyó képlettel az a baj, hogy egy újabb igény esetén nehéz követni.
Sok szerencsét hozzá!

Több változat készült, és közben az idő is szépen telt.
Fel kellene tenned a jelenlegi változatot, hogy kiderüljön, hol állsz most.

Egy üres oszlopban végig viszed a lenti képletet, majd ezt összegzed a SZUM függvénnyel.
=HA(HÉT.NAPJA(A6;2)<5;9;HA(HÉT.NAPJA(A6;2)=5;6;0))

Nálam a makrót tartalmazó fájl az F:\Otthoni\macros mappában van. A makró indításakor az a mappa nyílik meg, amit az Excel beállításakor a Mentés menüpontban a Helyi fájlok alapértelmezett helye rovatban megadtam. Az adataimat, fájljaimat soha nem mentem a C meghajtóra. A Te feladatodhoz F:\Otthoni\macros\Checklista fát készítettem, ezen belül vannak az évek – jelenleg csak egy, 2019.
Megnyílik a FileDialog, kiválasztom a megfelelőt, ezzel el is mentettem.

Sub Pdf_mentes()
    Dim utvonal As String, FD, FN As String
    
    Sheets("Munka2").Select
    Set FD = Application.FileDialog(4)  'mappa választás
    With FD
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Nem választottál útvonalat, befejezzük.", vbInformation, "Értesítés"
            Exit Sub
        Else
            utvonal = .SelectedItems(1) & "\"
        End If
    End With
    
    FN = "Csekklista " & Format(Range("L1"), "yyyy.mm.dd hh_mm") & ".pdf"
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=utvonal & FN, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub

A kettőspontot nem lehet a fájlnévbe írni, marad az alsó kötőjel.
Csatolom az újabb verziót.

Nagyon jó, hogy foglalkoztál vele, mert amiket a kutatásod közben megtanultál, az fixen megmarad az emlékezetedben.
Két képlethez újabb magyarázatot írtam, remélem, érthetően.

Jó reggelt!

Azt írtam, hogy mikor egy új sor utolsó adatát – a C mérést – beviszed, akkor végzi el a makró a feladatot.
Átalakítottam a füzetet makrók nélkülire. Ezzel csak az a baj, hogy nem végzi el a pdf-be mentést, de legalább tudom csatolni.

Hol maradt a csatolás?

Újabban a data.hu sem fogadja az xlsm kiterjesztésű fájlokat. Bemásolom ide a makróját.

Sub Nyomtatas()
    Dim uzlet, sor As Integer, db, kimeno As String, x As Integer, oszlop As Integer
    Dim hol, szam As Integer, ide As Integer
    
    Sheets("Nyomtatandó").Select
    
    sor = 2
    Do While Sheets("Munka1").Cells(sor, "A") <> ""
        Range("A:C").ClearContents
        uzlet = Sheets("Munka1").Cells(sor, "A")
        hol = Application.Match(uzlet, Sheets("Munka2").Columns(1), 0)
        kimeno = Sheets("Munka2").Cells(hol, 2)
        If Sheets("Munka1").Cells(sor, "B") <> "" Then
            hol = Application.Match(uzlet, Sheets("Munka1").Columns(1), 0)
            db = Application.WorksheetFunction.RoundUp(Sheets("Munka1").Cells(hol, 2) / 3, 0)
            szam = 1: ide = 1
            Do While szam <= db
                For oszlop = 1 To 3
                    Cells(ide, oszlop) = "Üzlet száma: " & uzlet & vbLf & "Kimenő sor: " & kimeno _
                        & vbLf & Format(Date, "yyyy.mm.dd")
                Next
                ide = ide + 1
                szam = szam + 1
            Loop
                
            Range("A1").CurrentRegion.Select
            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

        End If
        sor = sor + 1
    Loop
End Sub

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

Itt az automatikus javításhoz beírt szavakat lehet javíttatni. Pl. a hogz beírása után kijavítja hogy-ra.

Nem egészen ide tartozik, de érdemes rövidítéseket bevinni. Egy alkalommal sokszor kellett (volna) leírnom egy táblázatba a zöld/sárga vezeték kifejezést. A Módosítandó rovatba beírtam a zs-t (fontos, hogy ne legyen értelmes szó), a Jó szöveghez pedig a hosszú szöveget. Ebből kisebb galiba lett, mert a fájlt átadtam valakinek, és mint kiderült, vitte a kibővített szótárat magával. Mikor be akart írni rövidítve az egy nevet, Molnár Zsigmondot (Molnár Zs), Molnár zöld/sárga vezeték lett belőle. 🙂

Megoldás lehet a KEREKÍTÉS függvény.

=KEREKÍTÉS(SZUM(D2:D6462);0)

Természetesen nem hasonlítottam össze a 644 cella adatait. Szűrtem a nem nulla, és nem 1,15961E-11 értékre, Kijelöltem a látható cellákat, mire a státuszsorban megjelent az összegük. Ez megegyezett a SZUM-os cella értékével.

If Target.HasFormula = False Then ActiveCell.Value=ActiveCell.Value 'nem képlet

Szia!

Másképp oldanám meg. A Névkezelőben új nevet vettem fel, a neve Képlet. A Hivatkozás rovatba írtam a képletet, ami az egyszerűség kedvéért egy szorzás. Ezt adtam meg a C1-ben állva. A C oszlopban =Képlet szerepel, ami összeszorozza az azonos sor A és B celláját. Nézd meg a H oszlopban állva a Névkezelő Képlet-ét, ott már az F és G cellákat szorozza össze, vagyis a tőle balra szereplő két oszlop tagjait.
Most a Névkezelőben írd át a szorzást pl. összegzésre, és csodálkozz rá az eredményre a csatolt fájlban.
Nem kell kijelölgetned és másolgatnod.

Üd, Kati

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

Keress rá ilyesmire: eseménykezelés, excel, vba. Jobban jársz, mintha én próbálnám elmagyarázni.

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: 6 years, 9 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: 7 years, 2 months 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.