楼主
0Mouse |
Q：如何运用VBA提取各车间收入排名前十的记录到新工作表中并各自进行降序排列呢？
数据表：
结果表：
A：代码如下：- Sub 运用VBA提取各车间收入排名前十的记录到新工作表中并各自进行降序排列()
- Dim r%, arr, i%, j%, k%, brr, crr, z%
- On Error Resume Next '如果“提取”工作表不存在，删除时会出错，故加上容错语句。
- Application.DisplayAlerts = False
- Sheets("提取").Delete
- Application.DisplayAlerts = True
- Sheet1.Copy , Sheet1 '复制Sheet1，放置在Sheet1右侧。
- ActiveSheet.Name = "提取"
- [I1] = "辅助"
- [I2] = "=IF(A2=A1,I1,N(I1)+1)" '公式辅助列用于保持各车间的先后顺序不变。
- r = Cells(Rows.Count, 1).End(xlUp).Row
- Range("I2").AutoFill Range("I2:I" & r) '填充公式
- Range("A1:I" & r).Sort Key1:=Range("I2"), Order1:=xlAscending, Key2:=Range _
- ("F2"), Order2:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase _
- :=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
- xlSortNormal, DataOption2:=xlSortNormal '以“辅助”为第一关键字，以“收入”为第2关键字排序。
- arr = Range("A1:I" & r + 1).Value
- ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 1)
- j = 1: z = 1
- For k = 1 To UBound(brr, 2)
- brr(z, k) = arr(2, k)
- Next
- For i = 3 To UBound(arr)
- If arr(i, UBound(arr, 2)) = arr(i - 1, UBound(arr, 2)) Then
- j = j + 1
- If j <= 10 Then
- z = z + 1
- For k = 1 To UBound(brr, 2)
- brr(z, k) = arr(i, k)
- Next
- End If
- Else
- j = 1: z = z + 2 '各车间记录之间插入一个空行，故加2。
- For k = 1 To UBound(brr, 2)
- brr(z, k) = arr(i, k)
- Next
- End If
- Next
- Range("2:" & Rows.Count).ClearContents '清除第2行以下的所有记录
- [I1] = ""
- [A2].Resize(z, UBound(brr, 2)) = brr
- Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":A" & Rows.Count).EntireRow.Delete '删除多余边框线所在的行
- [A1].Select
- End Sub
附件：
 运用VBA提取各车间收入排名前十的记录到新工作表中并各自进行降序排列.rar
|