合并单元怎么样排序！

吴虾咪

Sub 排序()
Range("A2:B" & [A65536].End(xlUp).Row).Sort Key1:=Range("B2"), Order1:=xlDescending
End Sub


可以了，打扰了

吴虾咪

Sub 排序1()
Range("BE3:BF" & [A65536].End(xlUp).Row).Sort Key1:=Range("BF3"), Order1:=xlDescending
End Sub

我上传的符件我试一下，合并是可以的。为啥我这在BE例就不行了。好奇怪，是不是我前面有公式里所以就不行了吗 A65536 我改了也不行。

aman1516

你这种是合并单元格完全一致有规律的情况下才可以排序，
你把DE列数据放到AB列后面后面再看下能否排序？
转换一下，用个数组，把每个合并单元格（行）区域作为一个元素，再排序即可

aman1516

方法1：

1. Sub SortestI()
   
2. Dim r%, i%, m
   
3. Dim Arr(), Brr
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. With Worksheets("Sheet1")
   
7.      r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.      m = 0
   
9.      For i = 2 To r
   
10.          If .Cells(i, 1).MergeArea.Cells(1, 1).Address = .Cells(i, 1).Address Then
    
11.             m = m + 1
    
12.             ReDim Preserve Arr(1 To 3, 1 To m)
    
13.             Arr(1, m) = i
    
14.             Arr(2, m) = .Cells(i, 1).MergeArea.Rows.Count
    
15.             Arr(3, m) = .Cells(i, 2).Value
    
16.          End If
    
17.      Next
    
18.      For i = 1 To UBound(Arr, 2) - 1
    
19.          p = i
    
20.          For j = i + 1 To UBound(Arr, 2)
    
21.              If Arr(3, p) < Arr(3, j) Then
    
22.                 p = j
    
23.              End If
    
24.          Next
    
25.          If p <> i Then
    
26.             For K = 1 To UBound(Arr)
    
27.                 temp = Arr(K, i)
    
28.                 Arr(K, i) = Arr(K, p)
    
29.                 Arr(K, p) = temp
    
30.             Next
    
31.          End If
    
32.      Next
    
33.      i1 = r + 1
    
34.      For K = 1 To UBound(Arr, 2)
    
35.          .Cells(Arr(1, K), 1).Resize(Arr(2, K), 2).Copy .Cells(i1, 1)
    
36.          i1 = i1 + Arr(2, K)
    
37.      Next
    
38.      .Range("A2:B" & r).Delete shift:=xlUp
    
39. End With
    
40. Application.DisplayAlerts = True
    
41. Application.ScreenUpdating = True
    
42. MsgBox "OK！"
    
43. End Sub

复制代码

方法2：

1. Sub SortestII()
   
2. Dim r%, i%, m
   
3. Dim Arr(), Brr
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. With Worksheets("Sheet1")
   
7.      r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.      m = 0
   
9.      For i = 2 To r
   
10.          If .Cells(i, 1).MergeArea.Cells(1, 1).Address = .Cells(i, 1).Address Then
    
11.             m = m + 1
    
12.             ReDim Preserve Arr(1 To 2, 1 To m)
    
13.             Set Arr(1, m) = .Cells(i, 1).Resize(.Cells(i, 1).MergeArea.Rows.Count, 2)
    
14.             Arr(2, m) = .Cells(i, 2).Value
    
15.          End If
    
16.      Next
    
17.      For i = 1 To UBound(Arr, 2) - 1
    
18.          p = i
    
19.          For j = i + 1 To UBound(Arr, 2)
    
20.              If Arr(2, p) < Arr(2, j) Then
    
21.                 p = j
    
22.              End If
    
23.          Next
    
24.          If p <> i Then
    
25.             For K = 1 To UBound(Arr)
    
26.                 If K = 1 Then
    
27.                    Set temp = Arr(K, i)
    
28.                    Set Arr(K, i) = Arr(K, p)
    
29.                    Set Arr(K, p) = temp
    
30.                 Else
    
31.                    temp = Arr(K, i)
    
32.                    Arr(K, i) = Arr(K, p)
    
33.                    Arr(K, p) = temp
    
34.                 End If
    
35.             Next
    
36.          End If
    
37.      Next
    
38.      i1 = r + 1
    
39.      For K = 1 To UBound(Arr, 2)
    
40.          Arr(1, K).Copy .Cells(i1, 1)
    
41.          i1 = i1 + Arr(1, K).Rows.Count
    
42.      Next
    
43.      .Range("A2:B" & r).Delete shift:=xlUp
    
44. End With
    
45. Application.DisplayAlerts = True
    
46. Application.ScreenUpdating = True
    
47. MsgBox "OK！"
    
48. End Sub

复制代码

aman1516

详见附件：
合并单元格排序II.rar (26.43 KB, 下载次数: 6)

2022-12-29 10:57 上传

点击文件名下载附件