Hirdetés

  2. Fórumok
  3. OS, alkalmazások
  4. Microsoft Excel topic
  5. (kiemelt téma)
Legfrissebb anyagok
  • Téma összefoglaló
    Utoljára frissítve: 2023-11-13 08:31

    LOGOUT

    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

  • #13222 Delila_1 veterán plaschil #13220
    Új Válasz #13222
    Ú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 plaschil #13220 üzenetére

    A makró az N oszlopba kigyűjti az A oszlopban lévő szövegeket, és mindegyik mellé beírja csökkenő sorrendben a hozzá tartozó top5-öt az O:S oszlopba.
    Ha 100-nál több féle adatod lehet az A oszlopban, a makróban jelzett sorban írhatod át.

    Sub Top5()
    Dim sor As Long, sor1 As Long
    Dim usor As Long, usor1, cim, ertek
    Dim T(100, 5) '***** Itt írd át a 100-at *****
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    usor = ActiveSheet.UsedRange.Rows.Count
    Columns("A:A").Select
    Range("A1:A" & usor).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
    "N1"), Unique:=True

    usor1 = Range("N1").End(xlDown).Row
    For sor1 = 2 To usor1
    cim = Cells(sor1, 14)
    For sor = 2 To usor
    ertek = Cells(sor, 2)
    If Cells(sor, 1) = cim Then
    If ertek > T(sor1 - 1, 1) Then
    T(sor1 - 1, 5) = T(sor1 - 1, 4)
    T(sor1 - 1, 4) = T(sor1 - 1, 3)
    T(sor1 - 1, 3) = T(sor1 - 1, 2)
    T(sor1 - 1, 2) = T(sor1 - 1, 1)
    T(sor1 - 1, 1) = ertek
    GoTo Köv
    End If
    If ertek > T(sor1 - 1, 2) Then
    T(sor1 - 1, 5) = T(sor1 - 1, 4)
    T(sor1 - 1, 4) = T(sor1 - 1, 3)
    T(sor1 - 1, 3) = T(sor1 - 1, 2)
    T(sor1 - 1, 2) = ertek
    GoTo Köv
    End If
    If ertek > T(sor1 - 1, 3) Then
    T(sor1 - 1, 5) = T(sor1 - 1, 4)
    T(sor1 - 1, 4) = T(sor1 - 1, 3)
    T(sor1 - 1, 3) = T(sor1 - 1, 2)
    T(sor1 - 1, 3) = ertek
    GoTo Köv
    End If
    If ertek > T(sor1 - 1, 4) Then
    T(sor1 - 1, 5) = T(sor1 - 1, 4)
    T(sor1 - 1, 4) = T(sor1 - 1, 3)
    T(sor1 - 1, 4) = ertek
    GoTo Köv
    End If
    If ertek > T(sor1 - 1, 5) Then T(sor1 - 1, 5) = ertek
    End If
    Köv:
    Next
    Range("O" & sor1) = T(sor1 - 1, 1)
    Range("P" & sor1) = T(sor1 - 1, 2)
    Range("Q" & sor1) = T(sor1 - 1, 3)
    Range("R" & sor1) = T(sor1 - 1, 4)
    Range("S" & sor1) = T(sor1 - 1, 5)
    Next

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    End Sub

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