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: 3 years, 7 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"

Szia!

Igen, lehet.

ActiveSheet.Range("$A$1:$F$6").AutoFilter Field:=5, Criteria1:=Range("N1")

Itt az A1:F6 tartomány E oszlopát szűrjük az N1 cella tartalma szerint. Ide írhatsz relációs jeles értéket is, pl. <=500,
vagy a T* tartalomnál a T-vel kezdődő adatokra kapsz szűrést.

Üdv,
Delila

Szia Ákos!

Tudja a szorzatösszeg, ha megmondod neki.
=SZORZATÖSSZEG(KEREKÍTÉS(B2:B5;0);KEREKÍTÉS(C2:C5;0))

Kati

Nagyszerű!
Eddig nem vettem észre a MAXHA függvényt.

Szia Imi!

Valóban a kérdezőnek dinamikus képletre van szüksége.
Azért nem bánom, hogy feltettem ide a lapok egyes celláinak összegzését, mert nem sokan ismerik ezt a megoldást. Ha ide nem is stimmel, máshol (pl. 1 évhez 12 lap, majd ehhez egy összegző lap) alkalmazható.

Kati

Szia!

Örülök, hogy összejött.

Szia!

Nézd meg a csatolt képet!

Delila

Horváth Imi szavával: örülünk.

Szia!

3 lépésben át lehet alakítani mindet 26 karakteresre. Valószínű, hogy a képleteket össze lehet vonni, csak lusta vagyok hozzá.

Delila

Ha tartalmaz makrót, zip-be tömörítve tudod ide feltölteni.

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

Ciklus nélkül is meg lehet oldani. Az F2 képlete látszik a szerkesztőlécen. Ezt a makró írta be, addig, ameddig az A oszlopban van adat.

Sub Szumha()
    Dim usor As Long
    usor = Range("A" & Rows.Count).End(xlUp).Row
    Range("F2:F" & usor) = "=SUMIF(D:D,D2,E:E)"
End Sub

Szia!

Egy egyszerű feltételes formázással megoldható, mint a csatolt képen láthatod. A sárgával kiemelt részben az A1 helyett azt a cellát add meg, ahol a kijelölésed kezdődik.

Üdv,
Delila

Bevallom, még most sem értem, honnan veszed a 100, 202, 1, 196, stb. értékeket.
Transzponáltam a 2. sorba ezeket, a D3 képletét pedig másoltam jobbra és le.
Fogalmam sincs, hogy jó-e így.

Szia!

Nem saját készítésű, Krizsák László követte el évekkel ezelőtt.
Kipróbáltam, tudja a 10M-t.

Function Szam_kiiras(szam As Long) As String
    Dim j1, j10, j10a, j100
    j1 = Array("", "egy", "kettő", "három", "négy", "öt", "hat", "hét", "nyolc", "kilenc")
    j10 = Array("", "tíz", "húsz", "harminc", "negyven", "ötven", "hatvan", "hetven", "nyolcvan", "kilencven")
    j10a = Array("", "tizen", "huszon", "harminc", "negyven", "ötven", "hatvan", "hetven", "nyolcvan", "kilencven")
    j100 = Array("száz", "", "ezer", "millió", "milliárd")
    betu = ""
    If szam = 0 Then
        Szam_kiiras = "Nulla"
        Exit Function
    End If
    s = Format(szam, "0")
    j = 1
    While s <> ""
        i = Len(s) - 2
        If i < 1 Then i = 1
        s2 = Mid(s, i, 3)
        s = Left(s, i - 1)
        s3 = ""
        If Len(s2) = 3 Then
            s3 = s3 + j1(Asc(Mid(s2, 1, 1)) - 48)
            If Mid(s2, 1, 1) <> "0" Then s3 = s3 + j100(0)
            s2 = Right(s2, Len(s2) - 1)
        End If
        If Len(s2) = 2 Then
            If Mid(s2, 2, 1) = "0" Then
                s3 = s3 + j10(Asc(Mid(s2, 1, 1)) - 48)
            Else
                s3 = s3 + j10a(Asc(Mid(s2, 1, 1)) - 48)
            End If
            s2 = Right(s2, Len(s2) - 1)
        End If
        s3 = s3 + j1(Asc(Mid(s2, 1, 1)) - 48)
        If s3 <> "" Then s3 = s3 + j100(j)
        If (betu <> "") And (szam > 2000) And (s3 <> "") Then kot = "-" Else kot = ""
        betu = s3 + kot + betu
        j = j + 1
    Wend
    betu = UCase(Left(betu, 1)) & Right(betu, Len(betu) - 1)
    Szam_kiiras = betu
End Function

Delila

Igen. Az eredményekben az április is szerepel, pedig csak márciusig kellene.

Bocsi, csak most vettem észre.
https://forum.index.hu/Article/showArticle?la=148718083&t=9009340
Ezen a fórumon eléggé nehézkes a keresés,a 35466-os hsz-t kell nézni.

Szia!

Egy nem látható karakter, pl. szóköz lehet benne. A KÓD függvény visszaadja a hivatkozott cella első karakterének a ASCII kódját, ami szóköz esetén 32.
A HOSSZ függvényt is alkalmazhatod.

Delila

Szia!
A remek Villámkitöltés funkcióval oldanám meg.
A1-ben van a Julcsás szöveged. B1-be beírod a nevet. B2-re állva Kezdőlap, Szerkesztés, Kitöltés, Villámkitöltés.
Ennyi.

Delila

Látom, új kérdésként is feltetted, ott válaszoltam rá.

Szia!

Próbáld így:

Sub Masol_Torol()
    Dim ide As Long
    
    ide = Sheets("osszefuz").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("C").Range("b2:J11").Copy
    Sheets("osszefuz").Range("A" & ide).PasteSpecial xlPasteValues
    
    Sheets("betolto").Range("D1,J1,C4:D8,G4:H8").ClearContents
End Sub

Delila

Szia Attila!

Most csak 2007-es verzióm van egy „katasztrófa” miatt, Ebben a RANDBETWEEN függvényben adhatod meg a két szélső értéket a véletlenszámoknál.
Magasabb verziókban a VÉLETLEN.KÖZÖTT adja, de nem vagyok benne biztos.

Delila

Szia!
Tömbök, területek változóba tétele nélkül is meg lehet oldani.
2 makrót írtam, mert nem derült ki, hogy a másik lapon egymás mellé, vagy alá akarod másolni az adatokat.

Sub Masol_Munka1_re()   'egymás alá
    Dim oszlop As Integer, usor As Long, uoszlop As Integer, ide As Long
    usor = ActiveSheet.UsedRange.Rows.Count
    uoszlop = ActiveSheet.UsedRange.Columns.Count
    ide = 2
    For oszlop = 2 To uoszlop - 1 Step 2
        Range(Cells(2, oszlop), Cells(4, oszlop)).Copy Sheets("Munka1").Cells(ide, 1)
        Range(Cells(3, oszlop + 1), Cells(usor, oszlop + 1)).Copy Sheets("Munka1").Cells(ide + 1, 2)
        ide = Sheets("Munka1").Range("B" & Rows.Count).End(xlUp).Row + 1
    Next
End Sub

Sub Masol_Munka2_re()   'egymás mellé
    Dim oszlop As Integer, usor As Integer, uoszlop As Integer
    usor = ActiveSheet.UsedRange.Rows.Count
    uoszlop = ActiveSheet.UsedRange.Columns.Count
    For oszlop = 2 To uoszlop - 1 Step 2
        Range(Cells(2, oszlop), Cells(4, oszlop)).Copy Sheets("Munka2").Cells(2, oszlop - 1)
        Range(Cells(3, oszlop + 1), Cells(usor, oszlop + 1)).Copy Sheets("Munka2").Cells(3, oszlop)
    Next
End Sub

Delila

Van egy régi makróm, ami tartalomjegyzéket készít a lapokról, ahol a lapnevek linkek, a megfelelő lap A1 cellájára ugranak.
Mód van rá, hogy egyúttal minden lapra tegyen egy linket, amivel a tartalomjegyzék lapjára ugrorhatsz vissza.

Magyarázatokkal együtt küldöm a makrót.

Sub Tartalomjegyzek()
    'A makró egy tetszőleges nevű munkalapot szúr be a meglévőek elé.
    'Erre a munkalapra egy tartalomjegyzéket készít a többi munkalapot listázva,
    'hivatkozást is elhelyezve, amik az egyes munkalapok egy megadott cellájára mutatnak.
    'A lapokra vissza logikájú linket helyez el kérésre, egy megadott cellába.
    
    Dim TartalomLapnev As String, VisszaSzovege As String, VisszaHelye As String
    Dim aktiv As Integer, Vissza As Integer
    
    'Megkérdezi a felhasználótól, mi legyen a tartalomjegyzék munkalapjának a neve
    TartalomLapnev = InputBox("Mi legyen a tartalomjegyzék munkalapjának neve?", "Tartalomjegyzék munkalapjának neve")
    
    'Megkérdezi, szeretnénk-e vissza gombot elhelyezni a munkalapokon?
    Vissza = MsgBox("Legyen-e egy vissza logikájú link a munkalapokon?", 4, "Vissza logikájú link")
    
    'Ha igen, kérdezze meg, mi legyen a szöveg? pl. Alt+0171:«
    'és hol legyen az egyes lapokon
    If Vissza = 6 Then
        VisszaHelye = InputBox("Hova kerüljön a vissza logikájú link a lapokon?" & vbLf & "Pl.: A1", "Vissza logikájú link helye")
        VisszaSzovege = InputBox("Mi legyen a vissza logikájú link felirata?" & vbLf & "Pl. « (bal Alt+0171)", "Vissza logikájú link felirata")
    End If
    
    'Szúrjon be egy új munkalapot a meglévők elé a legelső helyre.
    ActiveWorkbook.Sheets.Add Before:=Worksheets(1)
    
    'Adja az új munkalapnak a felhasználó által megadott nevet
    Worksheets(1).Name = TartalomLapnev
    
    'Menjen végig a munkalapokon ...
    For aktiv = 2 To ActiveWorkbook.Sheets.Count
        '... és írja ezeknek a nevét sorszámmal ellátva az újonnan létrehozott lapra.
        Worksheets(1).Cells(aktiv, 1).Value = aktiv - 1 'sorszám
        Worksheets(1).Cells(aktiv, 2).Value = Worksheets(aktiv).Name    'lapnév
     
        'A munkalapok neveit tegye linkké
        With Worksheets(1)  'itt adhatjuk meg, hogy az egyes lapokon melyik cellára mutasson a link
            .Hyperlinks.Add Anchor:=.Cells(aktiv, 2), Address:="", _
                SubAddress:="'" & Worksheets(aktiv).Name & "'!A1", TextToDisplay:=Worksheets(aktiv).Name
        End With
        
        'Ha kértünk Vissza linket, hozza létre a vissza logikájú linket a megadott cellába
        If Vissza = 6 Then
            Worksheets(aktiv).Range(VisszaHelye).Value = VisszaSzovege
            With Worksheets(aktiv) 'itt adhatjuk meg, hogy a Vissza link melyik cellára álljon az első lapon
                .Hyperlinks.Add Anchor:=.Range(VisszaHelye), Address:="", _
                    SubAddress:="'" & TartalomLapnev & "'!B2", TextToDisplay:=VisszaSzovege
                .Range(VisszaHelye).Font.Bold = True
            End With
        End If
    Next aktiv
End Sub

:((

Szia Norbi!

A csatolt fájl nem egészen olyan, mint amit kértél, de talán ez is megteszi, míg nem kapsz másikat.
A cikkszámoknak emelkedő sorrendben kell lenniük, ahogy most is vannak.
A két HOL.VAN függvényt, és a névkezelőt nézd meg, azok alapján kapsz érvényesítési listát az I2 cellában.

Üdv,
Kati

Szia verax!

Először csak szövegesen írtam le a szerintem jó megoldást, még 19-én, 6:28-kor, amit a kérdező, kopisb
11:27-kor megköszönt, jónak minősített.
Másnap jöttél Te a kopisb.xlsx, majd a kopisb-1.xlsx fájlokkal. Az utóbbi harmadik lapja után szúrtam be a Munka4 lapot, és ezt az egyetlen Excel fájlt tettem fel kopisb-2.xlsx néven. Ott az E oszlop képletében a pontszámokat a B oszlopból veszem, ahol egész számok szerepelnek
=INDEX($A$1:$D$15;HOL.VAN(D2;A:A;0);2)
nem a formázás láttatja egészeknek.
Ezután már csak képeket linkeltem be ebből a fájlból, mert nem láttam értelmét újra és újra elküldeni a teljes fájlt.

Ennyit a fjordokról. Üdv,
Kati

A képleteket elég 2-től 7 sorig lemásolni.
Látod, nálam az E oszlopban egész számok szerepelnek.

Szerk.: beteszek egy újabb képet. A pontszámok feltehetően jobban eltérnek majd, mint a példában, nem lesz sok azonos helyezés.

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

Szia Péter!

A képlet (24,27-int(24,27))*400. Természetesen nem közvetlenül a számokat kell beírnod, hanem a megfelelő cellákra kell hivatkoznod.

Üdv,
Delila