Ongelma on seuraava.
Minulla on lista jossa nimi ja pistemäärä. Näistä sitten tehdään lista jossa on jokaisen nimi pisteet laskettuna yhteen. Nyt pitäisi vain saada järjestettyä sijoituksen siten että jos on kaksi tai useampi samoissa pisteissä niin se jolla on yhdestä kilpailusta isompi yksittäinen pistemäärä sillä olisi sijoitus parempi, vaikka ovatkin samoilla sijoituksilla.
Tämä on toteutettu siten että A=nimi B=pisteet, F=nimi ja G=laskettu pisteet yhteen. Tästä välilehdestä pisteet suodatetaan paremmuusjärjestyksen toiseen välilehteen.
Minulla on lista jossa nimi ja pistemäärä. Näistä sitten tehdään lista jossa on jokaisen nimi pisteet laskettuna yhteen. Nyt pitäisi vain saada järjestettyä sijoituksen siten että jos on kaksi tai useampi samoissa pisteissä niin se jolla on yhdestä kilpailusta isompi yksittäinen pistemäärä sillä olisi sijoitus parempi, vaikka ovatkin samoilla sijoituksilla.
Tämä on toteutettu siten että A=nimi B=pisteet, F=nimi ja G=laskettu pisteet yhteen. Tästä välilehdestä pisteet suodatetaan paremmuusjärjestyksen toiseen välilehteen.
Vastaukset 3
Vanhimmat
Otat listaan, jossa henkilöiden nimien lisäksi on pistemäärät, maksimiarvot funktiolla MAX() (MAKS) ja sijoitat ne pistemäärän viereiseen sarakkeeseen.
Kopioi nimilista, pistemäärineen ja maksimiarvoineen ja liitä taulukon tyhjälle alueelle "Liitä määräten" - toiminnolla ja pelkät arvot.
Lajittelet nimet pistemäärä- ja maksimiarvojenmukaan, laskevaan järjestykseen.
Alkuperäiseen tauluun on lisätty maksipisteitä varten H-sarake. Kopioi koodi makromoduuliin. Muuta taulujen nimet ja solut tarpeitasi vastaaviksi. Makro tyhjentää kopiotaulusta koko sarakkeet A-B.
Sub LaskeJaKopioiPisteet()
Application.ScreenUpdating = False
Sheets("Taul2").Columns("A:B").ClearContents
Sheets("Taul1").Activate
Set rng = Range(Cells(1, 1), Cells(1, 1).End(xlDown))
rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("F1"), Unique:=True
Lr = Range("F2").End(xlDown).Row
For Each c In Range("F2:F" & Lr)
Range("A1").AutoFilter Field:=1, Criteria1:=c.Value
Pistemäärä = Application.Subtotal(9, Range("B2:B65536"))
Maksimipisteet = Application.Subtotal(4, Range("B2:B65536"))
Range("G" & c.Row) = Pistemäärä
Range("H" & c.Row) = Maksimipisteet
Next
ActiveSheet.AutoFilterMode = False
Range("F1:H" & Lr).Sort Key1:=Range("G2"), Order1:=xlDescending, Key2:=Range("H2") _
, Order2:=xlDescending, Header:=xlGuess
Range("F1:G" & Lr).Copy Destination:=Sheets("Taul2").Range("A1")
End Sub
Makro hässäkkä toimii, kiitos siitä!