Keresés

Új hozzászólás Aktív témák

  • Delila_1

    veterán

    válasz Zozzy #32565 üzenetére

    Ha a beírt függvénnyel kész vannak a lapok, nem akarsz mást ellenőrizni, módosítani rajtuk, akkor a mostani makróba az End Sub fölé írd be egy új sorba annak a makrónak a nevét, amelyiket a mentésre kiválasztottad (LapMentes, vagy MentTorol).
    Akkor elég a mostanit indítanod, minden feladatot elvégez.

  • Delila_1

    veterán

    válasz Zozzy #32565 üzenetére

    Van megoldás. :)

    Sub Kulon_Lapra_2()
    Dim sor As Long, lapnev As String, WS1 As Worksheet, usor As Long

    Application.ScreenUpdating = False
    Set WS1 = ActiveSheet

    'egyedi rekordok az AA oszlopba
    WS1.Range("B1:B" & Application.CountA(WS1.Columns(2))).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

    sor = 2
    Do While Cells(sor, "AA") <> ""
    lapnev = Cells(sor, "AA")

    WS1.Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:=lapnev 'szűrés

    Sheets.Add After:=Sheets(Sheets.Count) 'új lap létrehozása
    ActiveSheet.Name = lapnev

    WS1.Range("A1").CurrentRegion.Copy Sheets(lapnev).Cells(1) 'másolás
    'képlet az U:W-be
    usor = Application.WorksheetFunction.CountA(Columns(22)) + 1
    Range("U" & usor & ":W" & usor) = "=subtotal(9,U2:U" & usor - 1 & ")"

    WS1.Activate
    sor = sor + 1
    Loop
    WS1.Range("A1").CurrentRegion.AutoFilter Field:=2 'szűrő visszaállítása
    Application.ScreenUpdating = True
    End Sub

  • Delila_1

    veterán

    válasz Zozzy #32554 üzenetére

    Akkor gyorsítsunk – bár úgy tapasztaltam, hogy sok sor esetén nem túl gyors az Excelben a szűrés.
    A makró a B oszlop adataiból speciális szűréssel kimásolja az egyedi adatokat az AA oszlopba, onnan veszi, hogy milyen adatokra kell szűrni a tartományt. Ha az AA oszlopban vannak adataid, minden helyen írd át az AA-t nagyobb oszlop nevére.

    Az adatokat tartalmazó lapon állva kell indítani a makrót.

    Sub Kulon_Lapra_1()
    Dim sor As Long, lapnev As String, WS1 As Worksheet

    Application.ScreenUpdating = False
    Set WS1 = ActiveSheet

    'egyedi rekordok az AA oszlopba
    WS1.Range("B1:B" & Application.CountA(WS1.Columns(2))).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

    sor = 2
    Do While Cells(sor, "AA") <> ""
    lapnev = Cells(sor, "AA")

    WS1.Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:=lapnev 'szűrés

    Sheets.Add After:=Sheets(Sheets.Count) 'új lap létrehozása
    ActiveSheet.Name = lapnev

    WS1.Range("A1").CurrentRegion.Copy Sheets(lapnev).Cells(1) 'másolás
    WS1.Activate
    sor = sor + 1
    Loop
    WS1.Range("A1").CurrentRegion.AutoFilter Field:=2 'szűrő visszaállítása
    Application.ScreenUpdating = True
    End Sub

  • Delila_1

    veterán

    válasz Zozzy #32552 üzenetére

    3 makrót írtam. Az első sorra veszi a B oszlop celláit. Ha még nincs ennek megfelelő lap a füzetben, létrehozza, átmásolja a címsort és az aktuális sort. Az új lap neve az aktuális sor B oszlopában lévő adat lesz. Ha már van ilyen nevű lap, az első üres sorába másolja az aktuális sort. Nem kell az első lapon rendezettnek lennie a táblának.

    A második sorra veszi a lapokat a másodiktól az utolsóig, Új füzetbe másolja az aktuális lapot, ezt elmenti a lapnév nevével az utvonal nevű változóban megadott mappába. Ezt a makró elején kell átírnod az
    utvonal = "C:\Temp\"
    sorban a saját mentési útvonaladra.

    Ha az eredeti füzetben nem akarod megtartani az újonnan létrehozott lapokat, akkor a második helyett a harmadik makrót futtasd. Ez nem másolja, hanem áthelyezi a lapokat 1-1 új füzetbe. Itt is át kell írnod az utvonal változó értékét.

    A két másolós makró feltételezi, hogy kezdetkor 1 lap volt a füzetedben.

    Sub Kulon_Lapra()
    Dim sor As Long, lapnev As String, a, hova As Long, WS1 As Worksheet

    Application.ScreenUpdating = False
    Set WS1 = ActiveSheet
    sor = 2
    Do While Cells(sor, 1) <> ""
    lapnev = Cells(sor, "B")
    On Error Resume Next
    Set a = Sheets(lapnev)
    If Err.Number <> 0 Then
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = lapnev
    WS1.Rows(1).Copy Sheets(lapnev).Cells(1)
    WS1.Activate
    End If
    On Error GoTo 0

    hova = Application.WorksheetFunction.CountA(Sheets(lapnev).Columns(1)) + 1
    Rows(sor).Copy Sheets(lapnev).Cells(hova, 1)
    sor = sor + 1
    Loop
    Application.ScreenUpdating = True
    End Sub

    Sub LapMentes()
    Dim lap As Long, utvonal As String, lapnev As String
    utvonal = "C:\Temp\"

    Application.ScreenUpdating = False
    For lap = 2 To Sheets.Count
    lapnev = Sheets(lap).Name
    Sheets(lapnev).Copy
    ActiveWorkbook.SaveAs Filename:=utvonal & lapnev & ".xlsx"
    ActiveWorkbook.Close
    Next
    Application.ScreenUpdating = True
    End Sub

    Sub MentTorol()
    Dim lap As Long, utvonal As String, lapnev As String
    utvonal = "C:\Temp\"

    Application.ScreenUpdating = False
    For lap = Sheets.Count To 2 Step -1
    lapnev = Sheets(lap).Name
    Sheets(lapnev).Move
    ActiveWorkbook.SaveAs Filename:=utvonal & lapnev & ".xlsx"
    ActiveWorkbook.Close
    Next
    Application.ScreenUpdating = True
    End Sub

  • azopi74

    addikt

    válasz Zozzy #26763 üzenetére

    Igen azt. Bocsi, nem néztem meg, magyar excelben hogyan fordították az iterációt. Most megtettem.

    Hát valóban közelítésnek :W bocs, nem akartalak félrevezetni, úgy gondoltam simán hagyták iterációnak vagy iteratív kalkulációnak. De nem, muszáj volt leferdíteni.

    Természetesen nem közelítésről van szó, és az iteráció sem közelítést jelent szó szerint sem, hanem ismétlődést (programozásban ciklus-nak is hívjuk). Csakhát úgy tűnik google translate-tel honosították az excelt :)
    Ugyanis matematikában valóban majnem a közelítés az iteráció szinonimája, mivel az ismétlődést tartalmazó algoritmusokat a matematikában általában valóban közelítésre szoktuk használni, de IT-ban nem csak (és nem elsősorban). Innen jöhetett a félreferdítés.

  • azopi74

    addikt

    válasz Zozzy #26758 üzenetére

    De legyen azért egy makró mentes megoldás is jó szokásom szerint : :)

    Iterációt állíts egyre, és írd A2-be:

    =HA(B2<>"";HA(A2="";MOST();A2);"")

  • Fferi50

    Topikgazda

    válasz Zozzy #26753 üzenetére

    Szia!

    Az A1 cellát másolod és ugyanoda beilleszted értékként, de ez elég macerás minden adatbevitel után.
    Ezért javaslom a következő makrót:

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 2 Then Exit Sub
    If Target.Value <> "" Then
    Application.EnableEvents = False
    Target.Offset(0, -1).Value = Now()
    Application.EnableEvents = True
    End If
    End Sub

    Ezt úgy viheted be, hogy a munkalapfülre jobb egérgombbal rákattintasz, kód megjelenítése, majd a megjelent kódlapon az üres területre bemásolod.

    A makró azt csinálja, ha a B oszlop egy cellájába adatot írsz (vagy megváltoztatod az ott levő adatot), akkor beírja az A oszlopban mellette levő cellába a Most függvény értékét, ami természetesen nem fog a továbbiakban változni.

    Üdv.

  • Delila_1

    veterán

    válasz Zozzy #26753 üzenetére

    A laphoz kell rendelned a makrót. Mikor a B oszlopba beírsz valamit, az A oszlop azonos sorában fixen, nem képletként megjelenik az idő. Az oszlop formátumát tetszésed szerint adhatod meg, dátummal, vagy anélkül.

    Ha törölsz a B-ben, az A azonos sorából is törlődik a beírt időpont. Ha 1-nél több cellába viszel be egyszerre adatot, akkor nem ír be semmit.

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Column = 2 Then
    If Target = "" Then
    Cells(Target.Row, 1) = ""
    Exit Sub
    Else
    Cells(Target.Row, 1) = Now
    End If
    End If
    End Sub

Új hozzászólás Aktív témák

Hirdetés