合并单元格降序排序 求助

976190982

合并单元格降序排序 求助

麻烦老师们帮忙看看，能否用vba实现，实在是莫法了   

求助.zip (87.17 KB, 下载次数: 49)

2020-6-20 14:57 上传

点击文件名下载附件

求助老师们     麻烦了    真的太难了              

谢谢老师们的回复    再次拜谢    由于一天要处理这样的数据100来张     原始数据能实现   但是要数据透视表，然后再匹配  这样我一天的工作量很恐怖，但是要把数据全部弄成这样一个模板  反而是增加工作量的    因此  我能不能求求老师们   帮俺整一个能可以自由选择排序区域  跟排序依据列的代码  真的感谢       当然  如果老师们嫌麻烦   哪我就只能知足用老师们提交的代码了   谢谢你们   也谢谢这个平台  爱你们。

蓝桥玄霜

合并单元格排序的例子：

xiangbaoan

………………

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, brr, i, j, k, m, cnt, p
  arr = Range("a1:e" & Cells(Rows.Count, "b").End(xlUp).Row + 1).Value
  ReDim pos(1 To UBound(arr, 1), 1 To 3)
  p = 1: brr = arr
  For i = 2 To UBound(arr, 1) - 1
    If Len(arr(i + 1, 4)) > 0 Or i = UBound(arr, 1) - 1 Then
      cnt = cnt + 1
      pos(cnt, 1) = p + 1: pos(cnt, 2) = i: pos(cnt, 3) = arr(p + 1, 4)
      p = i
    End If
  Next
  Call bsort(pos, 1, cnt, 1, UBound(pos, 2), 3)
  For i = 1 To cnt
    For j = pos(i, 1) To pos(i, 2)
      m = m + 1
      For k = 1 To UBound(arr, 2)
        brr(m, k) = arr(j, k)
      Next
    Next
  Next
  Call doevent(False)
  With [a2]
    .Resize(UBound(arr, 1), UBound(arr, 2)).Clear
    With .Resize(m, UBound(brr, 2))
      .Value = brr
      .Borders.LineStyle = xlContinuous
    End With
  End With
  p = 1
  j = Cells(Rows.Count, "b").End(xlUp).Row
  For i = 2 To j
    If Len(Cells(i + 1, "d")) > 0 Or i = j Then
      Cells(p + 1, "a").Resize(i - p).Merge
      Cells(p + 1, "d").Resize(i - p).Merge
      Cells(p + 1, "e").Resize(i - p).Merge
      p = i
    End If
  Next
  Call doevent(True)
End Sub

Function doevent(flag As Boolean)
  With Application
    .DisplayAlerts = flag
    .ScreenUpdating = flag
  End With
End Function

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) < arr(j + 1, key) Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
    Next
  Next
End Function

lwwy1981

http://club.excelhome.net/thread-1440172-1-1.html

976190982

lwwy1981 发表于 2020-6-20 16:10
http://club.excelhome.net/thread-1440172-1-1.html

这个我看过    不完全一样   奈何功底差    改不了

hcm19522

F2:I14 {=INDEX(A:A,100-RIGHT(LARGE(LOOKUP(ROW($2:$14),ROW($2:$14)/($D$2:$D$14<>""),$D$2:$D$14)/1%-ROW($2:$14),ROW(A1)),2))&""

格式化 F2:I14=MOD(COUNTIF($F$2:$F2,"><"),2)=0

976190982

hcm19522 发表于 2020-6-20 16:27
F2:I14 {=INDEX(A:A,100-RIGHT(LARGE(LOOKUP(ROW($2:$14),ROW($2:$14)/($D$2:$D$14""),$D$2:$D$14)/1%-ROW( ...

谢谢   非常感谢

976190982

一把小刀闯天下 发表于 2020-6-20 15:56
Option Explicit

Sub test()

谢谢    很感谢你的帮助

976190982

蓝桥玄霜 发表于 2020-6-20 15:54
合并单元格排序的例子：

谢谢蓝版   感谢