Szia!

A ThisWorkbook laphoz rendelve, az Open eseményben kell megírni a végrehajtandó feladatot.

Delila

Szia!

A laphoz kell rendelned egy eseménykezelő makrót. Lapfülön jobb klikk, Kód megjelenítése. Ezzel bejutottál a VB szerkesztőbe, az adott laphoz.
A kapott üres oldalra másold be.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 1 Then Cells(Target.Row, 2) = Date
End Sub

Ebben a makróban ha az A oszlopba írsz [Colums=1], akkor a B oszlopba az azonos sorba [Cells(Target.Row, 2] beírja fixen a mai dátumot.
A füzetet makróbarátként kell mentened.

Delila

Szia!
Próbáld meg ezzel:

Sub Masolas()
    Dim tabla As Range, usor As Integer, ide As Integer
    Sheets("Feladat").Select
    Set tabla = Range("C5").CurrentRegion
    tabla.Offset(1, 0).Resize(tabla.Rows.Count - 1, tabla.Columns.Count).ClearContents
    
    Sheets("Munka1").Select
    usor = Range("B5").End(xlDown).Row
    Range("B5:B" & usor).Copy
    Range("C5").PasteSpecial xlPasteValues
    Range("B5:C" & usor).Copy
    Sheets("Feladat").Range("C5").PasteSpecial xlPasteValues
    Range("F5:F" & usor).Copy
    Sheets("Feladat").Range("E5").PasteSpecial xlPasteValues
    
    ide = Sheets("Feladat").Range("C" & Rows.Count).End(xlUp).Row + 1
    Sheets("Munka2").Select
    usor = Range("B5").End(xlDown).Row
    Range("B5:B" & usor).Copy
    Range("C5").PasteSpecial xlPasteValues
    Range("B5:C" & usor).Copy
    Sheets("Feladat").Range("C" & ide).PasteSpecial xlPasteValues
    Range("G5:G" & usor).Copy
    Sheets("Feladat").Range("F5").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    
    Sheets("Feladat").Select
End Sub

Üdv,
Delila

Szia!

A Jegyzék lapon felveszünk egy segédoszlopot, ami megkeresi a Forduló lap C2:C5; D2;D4 … G2>G5 tartományban a Jegyzék A2 értékének a sorát.
Ezután a Jegyzék B2 cellájában az INDEX függvény kihozza a keresett nevet.

Üdv,
Delila

Szerk: találtam egy hibát. Ha senki nem végezte valamelyik munkát, akkor hibás az eredmény. A Jegyzék lap B2 cellájának a képlete legyen =HA(G2=0;””;INDEX(Forduló!$A$2:$G$5;G2;1)), ezt másold le a többi sorba.

A feltételek közé tedd be az útja szót is.
A hosszú képlet az út; u.; tér; utca; és köz szavakat vizsgálja.
A dátumkénti megjelenítés gáz.

🙂

Szia!

Itt a makró:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim utvonal As String, FN As String

    If Target.Column = 1 And Target.Row > 3 Then
        Application.EnableEvents = False
        utvonal = "D:\Gyűjtő mappa útvonala\"  '***************************
        FN = Target.Value & ".pdf"
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, 1), Address:= _
            utvonal & FN, _
            TextToDisplay:=FN
        Application.EnableEvents = True
    End If
End Sub

A csillagokkal jelzett sor végén ne hagyd ki a \ jelet!

Üdv,
Delila

Szia!

Makrós megoldást küldök. Felvettem egy új lapot az átalakításhoz, a neve „Munka1 (2)”.
A makró „Sortoresek” címre hallgat.
(Nem találom itt az egyes szövegrészek kiemelésének a formai lehetőségét, ezért idézőjelbe tettem a kiemelendő részeket.)

Delila

NINnek

Igen, el lehet hagyni az Application.EnableEvents sort, és a visszaállítását, de nem érdemes.

Stoppold le az első sort, majd a B oszlopba íráskor lépésenként futtasd a makrót.
Mikor a makró beírja a nevet a megfelelő oszlopba, előről indul, mivel a Cange eseményre ezt kell tennie. Igaz, a feltételnél nem csinál semmit,
mert nem a B oszlopban volt most a csere. Ezután újra indul a futás, ott folytatva, ahonnan kilépett.
Ha letiltod, majd a feladat végeztével újra engedélyezed az esemény kezelését, megspórolhatod ezt a kört.

Szia!

A Ctrl+F6 bill.kombináció a következő lapra visz, kódja ActiveWindow.ActivateNext.
A CTRL+Shift+F6 az előző lapot teszi aktívvá, kódja ActiveWindow.ActivatePrevious.
Készíthetsz egy lapra tartalomjegyzéket, ahol csatolással beviszed a lapok nevét, és az ugrás helyét, az egyes lapokra pedig szintén csatolással a tartalomjegyzék lapra ugrást.

Delila

Szia!

Nem látom a diagramnál a zárolt tulajdonság beállíthatóságát – valószínűleg egyes verzióknál van rá mód –, de ha a lapvédelemnél nem jelöljük be az Objektumok szerkesztése rovatot, nem szerkeszthetjük.

Delila

Szia!

Jelöld ki együttesen a két lapot, szúrd be az oszlopot, majd a második lapról töröld.

Delila

Szia!

Küldök egy makrós megoldást. Ide csak becsomagolva lehet feltenni a makróbarát füzeteket, a zip fájl kibontása után indíthatod a Start gombbal.
Most el kell mennem, de ha megfelel, később elmagyarázom a működését.

Üdv,
Delila

Igen, jól látod a cellák összevonásának a hátrányát.
Egészen furcsa dolgokat kaphatsz, ha pl. nem a címsorban, hanem az adatsorok között van itt-ott összevonás, és szűröd a tartományt.

Szia!

Nem olyan sok, 6 IF kell hozzá. Viszont lehet egyszerűsíteni.

Sub Health_Data_Fresh()
    With Sheets("service2")
        If .Range("bz2") <> .Range("ca1") Then
            .Range("bx6") = .Range("bz3") * .Range("ch6")
            .Range("bx7") = .Range("bz3") * .Range("ch7")
            .Range("bx8") = .Range("bz3") * .Range("ch8")
            .Range("bx9") = .Range("bz3") * .Range("ch9")
            .Range("bx10") = .Range("bz3") * .Range("ch10")
            .Range("bx11") = .Range("bz3") * .Range("ch11")
            If .Range("ci6") - .Range("bx6") <= 0 Then .Range("ci6") = 0 Else .Range("ci6") = .Range("ci6") - .Range("bx6")
            If .Range("ci7") - .Range("bx7") <= 0 Then .Range("ci7") = 0 Else .Range("ci7") = .Range("ci7") - .Range("bx7")
            'stb.
        End If
        .Range("bz3") = .Range("ca1")
    End With
End Sub

Delila

A Korábbi időpont és a Későbbi időpont címekhez összevontad a cellákat. Beírod a B1-be a szöveget, majd kijelölöd a B1:D1 tartományt. A cellaformázásnál a vízszintes elrendezésnél a Kijelölés közepére opciót választod.

A szorzások azért kellenek, mert a jobb, bal és közép függvények eredménye szöveg, de ha felszorozzuk 1-gyel, vagy hozzáadunk nullát, számként értelmezi az Excel a továbbiakban.

Szia!

Bevittem egy új lapot, másolat címen.

Delila

Szia!

Egyszer már megírtam az Excel-program_v2.xlsm fájlban, hogy ne duplázd az adatokat. Nálad teljesen azonos adatok szerepelnek a két lapon.
Semmi szükség az ide-oda hivatkozásokra.

Az érvényesítéshez szükséges adatokat – mivel összesen 3 van belőlük – a kép szerint is megadhatod, akkor nem lesz a tartomány útban.

Makrót tartalmazó füzetet tömörítve tudsz ide belinkelni.

Ezt kérted:
Pl.: “A1” cellába beviszek egy adatot, akkor a “B1” cellába kiírja az év-hónap-nap óra:perc -et.
Véletlenül a perc (minut) helyett másodpercet (seconds) adtam meg a formátumnál. Öreg hiba, mea culpa!

A Cells(Target.Row, Target.Column + 1) = Format(Now, "yyyy.mm.dd hh:ss") sorban a formátumot írd át így:
Cells(Target.Row, Target.Column + 1) = Format(Now, "yyyy-mm-dd hh:mm")
Ennél már az év-hó-nap közötti pontot is átírtam a kérésed szerinti kötőjelre.

Szia!

Ha már Imre felajánlotta, megírtam a makrót. 😀

Az A oszlopod ne legyen zárolt.
A lapodhoz kell rendelned: lapfülön jobb klikk, Kód megjelenítése. A jobb oldalon megjelenő üres felültre másold be a makrót.
A ActiveSheet.Protect Password:="aaa", UserInterfaceOnly:=True sorban most aaa a lapvédelem jelszava, ezt írd át kedved szerint. Ez a sor teszi lehetővé makróból a zárolt cellák felülírását.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count = 1 Then
        If Cells(Target.Row, 2) = "" Then
            Application.EnableEvents = False
            ActiveSheet.Protect Password:="aaa", UserInterfaceOnly:=True
            Cells(Target.Row, 2) = Format(Now, "yyyy.mm.dd hh:ss")
            Application.EnableEvents = True
        End If
    End If
End Sub

Lehet, hogy a makróban lévő idézőjeleket át kell írnod. Ha piros színnel jelenik meg nálad egy sor, ez a teendő.

Üdv, Delila

Szia!

Felveszel egy segédtáblát, ami nálam az I:J oszlopokban van. A címsort kihagyva nevet adsz, itt Tartomány. Mivel táblázattá alakítottam, a későbbi bővítések automatikusan benne lesznek a Tartományban.
A képletet látod a D oszlopban. Amennyiben nincs a Tartomány-ban a címzett neve, a HAHIBA függvény eredménye „egyéb” lesz.

Delila

Már tudod, miket kell átírnod a makrókban.

Option Explicit
Public kepszam As Integer

Sub Start()
    Cells(1) = "OK"
    kepszam = 1
    Kepek
End Sub

Sub Kepek()
    Const utvonal = "D:\Jpg\Új\"
    
    If Cells(1) = "OK" Then
        Application.OnTime Now + TimeSerial(0, 0, 2), "Kepek", , True
        ActiveSheet.Shapes.Range("Alakzat").Fill.UserPicture utvonal & kepszam & ".jpg"
    End If
    kepszam = kepszam + 1
    If kepszam > 7 Then kepszam = 1
End Sub

Sub Abbhagy()
    Cells(1) = "Stop"
End Sub

A Start és az Abbhagy makrókat 1-1 gombhoz rendelheted.

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

Szia,

Sub Kepek()
    Dim kepszam As Integer, utvonal As String
    
    Application.OnTime Now + TimeSerial(1, 0, 0), "Kepek", , True
    kepszam = Application.WorksheetFunction.RandBetween(1, 7) 'ahány képed van
    utvonal = "D:\Jpg\Új\"  'saját útvonaladat add meg
    ActiveSheet.Shapes.Range("Alakzat").Fill.UserPicture utvonal & kepszam & ".jpg" 'saját alakzatod nevét add meg
End Sub

A képek neve sorszám legyen. 1.jpg, 2.jpg, stb.

Delila

• A hozzászólás módosításra került: 1 year, 3 months telt el-delila. Indok: Képnevek

Szia!

Laphoz rendelt makró.
Ha csak egy ugrást akarsz létrehozni, elég 1 sor:
If Target.Address=”$A$10″ Then Range(„A15”).Select

A Select Case utasításokkal több ugrást megadhatsz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address
        Case "$A$10": Range("A15").Select
        Case "$B$4": Range("B10").Select
        Case "$D$6": Range("D3").Select
        Case "$E$4": Range("b10").Select
        Case "$E$12": Range("F5").Select
    End Select
End Sub

Delila

Szia!

Használd az autoszűrőt, és a RÉSZÖSSZEG függvényt!

Delila

Csak az fontos, hogy a több vessző törlése előbb legyen, mint a kevesebbé. Érthető lesz, ha végig gondolod a logikáját.

Szia!

Nálam a felülírandó adatok a B oszlopban vannak, segédoszlopként a C-t használom – amit a végén törlök.
55.000 sorral 12 másodperc alatt végzett.

Sub Csere()
    Dim usor As Long, ido As Date
    ido = Now
    usor = Range("B" & Rows.Count).End(xlUp).Row
    
    Range("C1:C" & usor).FormulaR1C1 = "=SUBSTITUTE(RC[-1],""\"","","")"
    Range("C1:C" & usor).Copy
    Range("B1").PasteSpecial xlPasteValues
    Range("C1:C" & usor).FormulaR1C1 = "=SUBSTITUTE(RC[-1],""/"","","")"
    Range("C1:C" & usor).Copy
    Range("B1").PasteSpecial xlPasteValues
    Range("C1:C" & usor).FormulaR1C1 = "=SUBSTITUTE(RC[-1],"" "","","")"
    Range("C1:C" & usor).Copy
    Range("B1").PasteSpecial xlPasteValues
    Range("C1:C" & usor).FormulaR1C1 = "=SUBSTITUTE(RC[-1],""_"","","")"
    Range("C1:C" & usor).Copy
    Range("B1").PasteSpecial xlPasteValues
    Range("C1:C" & usor).FormulaR1C1 = "=SUBSTITUTE(RC[-1],""-"","","")"
    Range("C1:C" & usor).Copy
    Range("B1").PasteSpecial xlPasteValues
    Range("C1:C" & usor).FormulaR1C1 = "=SUBSTITUTE(RC[-1],"",,,,,,,,"","","")"
    Range("C1:C" & usor).Copy
    Range("B1").PasteSpecial xlPasteValues
    Range("C1:C" & usor).FormulaR1C1 = "=SUBSTITUTE(RC[-1],"",,,"","","")"
    Range("C1:C" & usor).Copy
    Range("B1").PasteSpecial xlPasteValues
    Range("C1:C" & usor).FormulaR1C1 = "=SUBSTITUTE(RC[-1],"",,"","","")"
    Range("C1:C" & usor).Copy
    Range("B1").PasteSpecial xlPasteValues
    
    Columns(3).Delete
    MsgBox Format(Now - ido, "mm:ss")
End Sub

Delila

Igen, bőven elég lett volna az FKERES függvény.
Nálam a 2019-es verzióban a tömb bemásolását csak úgy tudtam megoldani, hogy előbb szövegként elmentettem egy txt fájlba.

Szia!

Az általad C-nek nevezett tartomány a C oszlopban van, a D pedig a D oszlopban, mindkettő az első sorban kezdődik.

Private Sub Cbo_A_Change()
    Dim usor As Long
    
    Select Case Cbo_A.Value
        Case Is = "Számlák"
            usor = Range("C" & Rows.Count).End(xlUp).Row
            Cbo_B.RowSource = "Munka1!C1:C" & usor
        Case Is = "Egyéb"
            usor = Range("D" & Rows.Count).End(xlUp).Row
            Cbo_B.RowSource = "Munka1!D1:D" & usor
    End Select
End Sub

Delila

A lapvédelem beállításakor engedélyezd az AutoSzűrő használatát.

Az általam küldött Teszt_1-import.zip füzet Alap (2) lapján ezt csinálja a makró. Most nem írom át az 5-e előtti 4 sor beszúrásához, azt „gyalog” is megteheted. 🙂

A Pihenőnap szöveg beírásához kijelölöd a Időelem h. szövege oszlopot az alsó adatig. F5-re bejön az Ugrás menü, ott Irányított, majd Üres cellák. Ez kijelöli az üreseket. Nem változtatsz a kijelölésen, hanem beírod a Pihenőnap szöveget, és Ctrl+ Enterrel viszed be egyszerre az összesbe.

Nem tudom, miért nincsenek ott a makrók. Bemásolom ide.
Alt+F11-re bejön a VB szerkesztő. Bal oldalon kiválasztod a füzetedet (ha van több is megnyitva), az Insert-Module kiválasztására kapsz egy új modult bal oldalon, Module1 névvel. A jobb oldali nagy üres mezőbe másold be ezeket:

Sub Osszesites()
    Dim lap As Integer, uoszlop As Integer, usorR As Long, lapnev As String
    Sheets("Riport_2").Cells.Delete
    Sheets(2).Range("A1:E1").Copy Sheets("Riport_2").Range("A1")
    
    For lap = 2 To Worksheets.Count
        If Left(Sheets(lap).Name, 6) <> "Riport" Then
            uoszlop = Sheets("Riport_2").Cells(1, Columns.Count).End(xlToLeft).Column + 1
            usorR = Sheets("Riport_2").Range("A" & Rows.Count).End(xlUp).Row + 1
            With Sheets(lap)
                Sheets(1).Cells(1, uoszlop) = "Hátralék " & .Name
                usor = .Range("A" & Rows.Count).End(xlUp).Row
                .Range("A2:E" & usor).Copy Sheets(1).Range("A" & usorR)
                .Range("F2:F" & usor).Copy Sheets(1).Cells(usorR, uoszlop)
            End With
        End If
    Next
    Rendez uoszlop
End Sub

Sub Rendez(uoszlop)
    Sheets("Riport_2").Select
    usor = Range("A" & Rows.Count).End(xlUp).Row
    
    ActiveWorkbook.Worksheets("Riport_2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Riport_2").Sort.SortFields.Add2 Key:=Range("B1:B" & usor), _
        SortOn:=xlSortOnValues, Order:=xlAscending
    ActiveWorkbook.Worksheets("Riport_2").Sort.SortFields.Add2 Key:=Range("D1:D" & usor), _
         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Riport_2").Sort.SortFields.Add2 Key:=Range("A1:A" & usor), _
         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Riport_2").Sort
        .SetRange Range(Cells(2, 1), Cells(usor, uoszlop))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Egyesites uoszlop
End Sub

Sub Egyesites(uoszlop)
    Dim oszlop As Integer
    
    Sheets("Riport_2").Select
    usor = Range("A" & Rows.Count).End(xlUp).Row
    uoszlop = Cells(1, Columns.Count).End(xlToLeft).Column
    
    For sor = usor To 3 Step -1
        If Cells(sor, 1) = Cells(sor - 1, 1) And Cells(sor, 2) = Cells(sor - 1, 2) _
            And Cells(sor, 4) = Cells(sor - 1, 4) Then
            For oszlop = 6 To uoszlop
                Cells(sor - 1, oszlop) = Cells(sor, oszlop) + Cells(sor - 1, oszlop)
            Next
            Rows(sor).Delete
        End If
    Next
    
    Cells.EntireColumn.AutoFit
End Sub

A felsőt kell indítanod, az meghívja a másik kettőt.

Szia!

Az Alap lapra bevittem, amit az Eredmény lapon összeállítottál.

Nem tudom, miért akarod beszúrni a hiányzó dátumokat, de írtam hozzá egy kis makrót – ezért makróbarát a fájl. Az „Alap (2)” lapon indítva beszúrja a sorokat, és beírja a hiányzó dátumokat.

Üdv,
Delila

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

Szia!

Magyar Excelnél a képlet
=INDEX(A1:A6;MÓDUSZ(HOL.VAN(A1:A6;A1:A6;0)))

Delila

Mese a csatolt fájlban.

Szia!

Nem vagyok Imre, de azért megpróbálok segíteni.
Az A1:A10 feltételes formázási képlete legyen =SZUM($B1:$H1)>0

Üdv,
Delila

Hurrá!

Most már sokkal jobb a formázás.
A szűrőt a helyedben az 5. sorba tenném az első helyett, akkor még hasznát is vehetnéd.

Szia!

Próbáld így:
If Cells(i, j).FormatConditions(1).Interior.ColorIndex = 3 Then Cells(i, j).FormatConditions(1).Interior.ColorIndex = 5
A lényeg a FormatConditions.

Delila

Nem sikerült időben kijavítani.
A C2 képlete rövidebben:
=HA(VAGY(ÜRES(B2);TÍPUS(B2)<>1);"Nincs számadat";HA(B2=MEDIÁN(B2;$J$2;$J$3);"OK";"Nem OK"))

Szívesen. Remélem, sikerrel átalakítottad a saját igényedhez.

A csatolt füzeted C oszlopa jól van formázva, de be kell vinned egy új feltételt a 0 alatti értékekre: =C15<0
Nézd meg a névkezelőt, van egy halom érvénytelen tartományod.

A sárgánál a <5 feltétel tartalmazza az üres értéket is, azért kell betenni feltételként, hogy erre ne vonatkozzon. A zöldnél fix az 5 és 7 között nem lehet üres cellaérték.

Szívesen. 🙂

Szia!

A ThisWorkbook laphoz rendeld a makrót. A csillagozott sorban állíthatod be, hogy melyik napon másoljon.

Private Sub Workbook_Open()
    If Day(Date) = 10 Then  '*********
        Columns(4).Copy
        Range("E1").PasteSpecial xlPasteValues
    End If
End Sub

Azt biztosan meg tudod adni, hogy ha a hónap megadott napja hétvégére esik [WeekDay(Date,2]>5, akkor a következő hétfőn másoljon.

Addig ügyeskedtem, míg sikerült innen kitörölnöm a tömörített fájlt. Azt hittem, lehet több csatolmány, de nem.

Szia!

Makróval nagyon gyorsan létre lehet hozni a sok jelölőnégyzetet.
Csatoltam a makróbarát füzetet, tömörítve, mert csak így fogadja el a fórum.
Mese a fájlban.

Delila

Szívesen. 🙂

Szia Imre!

Mivel az időpontok (feltehetően) emelkedő sorrendben vannak, egyszerűbben is meghatározható a Max és Min érték.

Delila

Szia!

Eszerint nem 1, hanem több oszlop tartalma szerint kell szűrnöd a táblát.
A képen látod a G2 cella képletét, amit a többi sorra is lemásolhatsz. Ezután a G oszlopra kell szűrni azokat a sorokat, ahol az érték nagyobb, mint nulla.
A makró így módosul:
ActiveSheet.Range("$A$1:$G$20").AutoFilter Field:=7, Criteria1:=">0"