Hirdetés

  2. Fórumok
  3. OS, alkalmazások
  4. Microsoft Excel topic
  5. (kiemelt téma)

Hirdetés

100 000 érv a ReGalaxy mellett: Vásárolj Galaxy Z Fold7 I Z Flip7 vagy Galaxy S25 szériás készüléket, és régi mobilod felújítását 100 000 Ft-ig mi álljuk!
  • Téma összefoglaló
    Utoljára frissítve: 2023-11-13 08:31

    Mobilarena

    A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
    Kérdés felvetése előtt olvasd el, ha még nem tetted.

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

  • #32566 Delila_1 veterán Zozzy #32565
    Új Válasz #32566
    Új hozzászólás
    Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra
    Privát üzenet küldése

    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

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