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

• #13222 Delila_1 veterán plaschil #13220

  Új Válasz 2012-03-20 17:12:10 #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