請vba高手幫幫忙,
我有一個excel如圖片,
想寫vba來做排序,
條件是根據總排名來排序,
但還要比對本身自己的部門排名,
像例子里面AA雖然總排名第1,
但在部門3里面他是第2,
所以他就必須讓出來,
調整排名到CC(部門3第1名)後面,
BB則往前遞補取代第1,
最終結果就是像E欄調整後排名,
請問vba高手如何寫呢?
Private Sub CommandButton1_Click()
Dim rowmax As Integer
Dim temp1, temp2 As String
Dim temp3, temp4 As Integer
Dim getdata As Boolean
Dim num As Integer
Dim no As Integer
num = 0
no = 0
rowmax = Range("A1").End(xlDown).Row
'清除調整後排名
For i = 2 To rowmax
Cells(i, 5) = ""
Next i
'原始資料先依照總排名、部門排名、部門代號、學生姓名排序
Range("A1:D" & rowmax).Select
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add Key:=Range("D2:D" & rowmax), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add Key:=Range("C2:C" & rowmax), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add Key:=Range("B2:B" & rowmax), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add Key:=Range("A2:A" & rowmax), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("工作表1").Sort
.SetRange Range("A1:D" & rowmax)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For i = 2 To rowmax - 1
getdata = False
For x = i + 1 To rowmax
If Cells(x, 2) = Cells(i, 2) Then
'同部門裡,部門排名在前面的人優先排名或部門裡同名次,總排名在前面的人優先排名
If (Cells(x, 3) < Cells(i, 3)) Or (Cells(x, 3) = Cells(i, 3) And Cells(x, 4) < Cells(i, 4)) Then
getdata = True
num = i
no = x
Exit For
End If
End If
Next x
If getdata = True Then
Rows(num).Cut
Rows(no + 1).Insert
i = num - 1
End If
Next i
'調整後排名,並列排名(連號)
'Dim orderno As Integer
'For i = 2 To rowmax
' If i = 2 Then
' orderno = 1
' Else
' If (Cells(i, 3) <> Cells(i - 1, 3)) Or (Cells(i, 4) <> Cells(i - 1, 4)) Then
' orderno = orderno + 1
' End If
' End If
' Cells(i, 5) = orderno
'Next i
'調整後排名,並列排名(不連號)
For i = 2 To rowmax
Cells(i, 5) = i - 1
If i > 2 Then
If (Cells(i, 3) = Cells(i - 1, 3)) And (Cells(i, 4) = Cells(i - 1, 4)) Then
Cells(i, 5) = Cells(i - 1, 5)
End If
End If
Next i
MsgBox "ok"
End Sub
寫出來了
1.原資料
2.執行VBA後
3.手動加入新排名後
4.最後結果(以原排序)