|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub test()
- Dim r%, i%, m5
- Dim arr(), brr
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- With Worksheets("代发")
- r = .Cells(.Rows.Count, 2).End(xlUp).Row
- m = 0
- For i = 2 To r
- If .Cells(i, 1).MergeArea.Cells(1, 1).Address = .Cells(i, 1).Address Then
- m = m + 1
- ReDim Preserve arr(1 To 3, 1 To m)
- arr(1, m) = i
- arr(2, m) = .Cells(i, 1).MergeArea.Rows.Count
- arr(3, m) = .Cells(i, 4).Value
- End If
- Next
- For i = 1 To UBound(arr, 2) - 1
- p = i
- For j = i + 1 To UBound(arr, 2)
- If arr(3, p) < arr(3, j) Then
- p = j
- End If
- Next
- If p <> i Then
- For k = 1 To UBound(arr)
- temp = arr(k, i)
- arr(k, i) = arr(k, p)
- arr(k, p) = temp
- Next
- End If
- Next
- i1 = r + 1
- For k = 1 To UBound(arr, 2)
- .Cells(arr(1, k), 1).Resize(arr(2, k), 5).Copy .Cells(i1, 1)
- i1 = i1 + arr(2, k)
- Next
- .Range("a2:e" & r).Delete shift:=xlUp
- End With
- Application.ScreenUpdating = True
- MsgBox "排序完毕!"
- End Sub
复制代码 |
评分
-
2
查看全部评分
-
|