ExcelVBAについて質問です。 下記のURLと同じような質問になってしまいますが、うまくいかなかったので具体的に質問させてください。

Visual Basic | Excel27閲覧xmlns="http://www.w3.org/2000/svg">500

ベストアンサー

0

その他の回答(3件)

0

評価の条件ですけど、文章をそのまま読むとこうなりますよね? 上位 0.31236381294 は ランク 2 上位 0.30541799287 は ランク 3 上位 0.29124284987 は ランク 4 上位 0.2378955375 は ランク 5 上位 0.207014875 は ランク 6 上位 0.1719405 は ランク 7 上位 0.09505 は ランク 8 上位 0.0495 は ランク 9 上位 0.01 は ランク 10 それをコードにするとこうなります。 マクロ名は Test です。 上記割合の解釈が異なるのであれば、そこを修正すれば意図通りの結果を得られると思います。 Public Sub Test() Dim sheet As Worksheet: Set sheet = Sheets("Sheet3") Dim last As Long: last = sheet.Cells(rows.Count, 2).End(xlUp).Row Dim rankingCells As Variant: rankingCells = GetRankingCells(sheet, 3, 4, last) Call SetResultCells(rankingCells, Range(sheet.Cells(2, 4), sheet.Cells(last, 4))) End Sub Private Function GetRankingCells(ByRef sheet As Worksheet, ByVal targetColumn As Integer, ByVal resultColumn As Integer, ByVal last As Long) As Variant Dim rankingCells As Variant: rankingCells = Range(sheet.Cells(2, targetColumn), sheet.Cells(last, resultColumn)) Dim i As Long For i = LBound(rankingCells, 1) To UBound(rankingCells, 1) rankingCells(i, 2) = WorksheetFunction.Rank_Eq(rankingCells(i, 1), Range(sheet.Cells(2, targetColumn), sheet.Cells(last, targetColumn))) Next GetRankingCells = rankingCells End Function Private Function SetResultCells(ByRef rankingCells As Variant, ByRef virtualCells As Range) Dim i As Long, rank As Integer, numOfTargets As Long: numOfTargets = UBound(rankingCells, 1) + 1 Dim criteria() As Double: criteria = GetEvaluationCriteria For rank = 2 To 10 For i = LBound(rankingCells, 1) To UBound(rankingCells, 1) If rank = 2 Or rank - 1 = virtualCells(i, 1).value Then Dim result As Integer: result = Evaluate(numOfTargets, rankingCells(i, 2), criteria, rank - 2, virtualCells(i, 1).value) If 0 < result Then virtualCells(i, 1).value = result End If End If Next Next End Function Private Function Evaluate(ByVal numOfTargets As Long, ByVal rank As Long, ByRef criteria() As Double, ByVal index As Integer, ByVal default As Integer) As Integer Dim result As Double: result = rank / numOfTargets If result <= criteria(index) Then Evaluate = index + 2 Exit Function End If Evaluate = default End Function Private Function GetEvaluationCriteria() As Double() Dim evaluationCriteria(8) As Double evaluationCriteria(0) = 0.31236381294 evaluationCriteria(1) = 0.30541799287 evaluationCriteria(2) = 0.29124284987 evaluationCriteria(3) = 0.2378955375 evaluationCriteria(4) = 0.207014875 evaluationCriteria(5) = 0.1719405 evaluationCriteria(6) = 0.09505 evaluationCriteria(7) = 0.0495 evaluationCriteria(8) = 0.01 GetEvaluationCriteria = evaluationCriteria End Function

0

こんな感じでは? Sub test() Dim i As Long, rw As Long, rng As Range, RP, RM rw = Cells(Rows.Count, 2).End(xlUp).Row RP = Split("1,6,16,35,60,90,97,99,100", ",") RM = Split("10,9,8,7,6,5,4,3,2", ",") Set rng = Range("C2:C" & rw) For i = UBound(RP) To 0 Step -1 Range("B:D").AutoFilter 2, Criteria1:=RP(i), Operator:=xlTop10Percent rng.SpecialCells(xlCellTypeVisible).Offset(, 1) = RM(i) Next rng.AutoFilter End Sub 無駄なようですが、割合の大きいほうから小さい方に向かって 処理を繰り返し、上書きすることで ロジックが簡単になっています。

0

考え方です。 1 C列の得点に基づいて降順にソートする 2 (1,5,10,19,25,30,7,2,1)%と言うことは (1, 6, 16, 35, 60, 90, 97, 99, 100)%と言うことになる。 従って A.「得点の上位1%」は、1行目~総行数の1%と言うことになる。 B.「1を除く上位5%」は、Aの次の行~総行数の6%と言うことになる。 C.「1,2を除く上位10%」は、Bの次の行~総行数の16%と言うことになる。 以下同じ。 上の考え方をコードにすると Dim R, R1, R2, J Dim Rank As Variant, Ten As Variant Const No = 100 '---(A) Rank = Array(1, 6, 16, 35, 60, 90, 97, 99, 100) '---(B) Ten = Array(10, 9, 8, 7, 6, 5, 4, 3, 2) '---(C) Range("A1:C" & No).Sort key1:=Range("C1"), order1:=xlDescending R1 = 1 For J = 0 To UBound(Rank)     R2 = WorksheetFunction.Round(No * (Rank(J) / 100), 0)     For R = R1 To R2         Cells(R, 4) = Ten(J)     Next R     R1 = R2 + 1 Next J 上記コードは人数も、評価の階層数も自由です。 ただし、以下を満たす必要があります。 1.(A)の数値を変更すれば、総人数は100人でなくても何人でもOK。 2.ただし、(総人数×最低%)が1を切る人数(今回は99人以下)は不可。 3.ランクの階層は(B)の配列の要素を変更すれば何階層でも可。 4.ただし、評価の配列である(C)の要素数は、(B)の要素数と同数でなければならない。