Sub GetSumRank() Dim iCl%, iLCl%, iRw%, iLRw%, iSex%, lSum1&, lSum2&, iRank%, lNum1%, lNum2% Application.ScreenUpdating = False With Worksheets(1) iLCl = .Cells(1, .Columns.Count).End(xlToLeft).Column iLRw = .Cells(.Rows.Count, 3).End(xlUp).Row For iCl = 3 To iLCl .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Cells(1, iCl), Order:=xlAscending With .Sort .SetRange Range(Cells(1, 1), Cells(iLRw, iLCl)) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With iRank = 1 lSum1 = 0 lSum2 = 0 lNum1 = 0 lNum2 = 0 For iRw = 2 To iLRw iSex = .Cells(iRw, 1).Value Select Case iSex Case 1 lSum1 = lSum1 + iRank '1394 lNum1 = lNum1 + 1 '45 Case 2 lSum2 = lSum2 + iRank '952 lNum2 = lNum2 + 1 '23 End Select iRank = iRank + 1 Next iRw .Cells(iLRw + 3, iCl).Value = lSum1 .Cells(iLRw + 4, iCl).Value = lSum2 .Cells(iLRw + 5, iCl).Formula = "=" & lNum1 & "*" & lNum2 & "-" & lSum1 & "+" & lNum1 & "*(" & lNum1 & "+1)/2" ' = 45*23-1394+45(45+1)/2=676 .Cells(iLRw + 6, iCl).Formula = "=" & lNum1 & "*" & lNum2 & "-" & lSum2 & "+" & lNum2 & "*(" & lNum2 & "+1)/2" ' = 45*23-952+23*(23+1)/2=359 Next iCl End With Application.ScreenUpdating = True End Sub |