单元格内容排序

mrshz

各位老师，单元格内容根据指定列内容排序，求助

sj15627581616

做个标记，静待老师们表演

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, s, t, p, dic, str
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a3:b" & [b3].End(xlDown).Row)
  For i = 1 To UBound(arr, 1)
    t = Split(arr(i, 1), Chr(10))
    dic.RemoveAll: p = UBound(t) + 1
    For j = 0 To UBound(t)
      If InStr(t(j), "]") Then dic(Split(t(j), "]")(0)) = j
    Next
    t = Split(arr(i, 2), Chr(10)): str = vbNullString
    ReDim brr(UBound(t), 1)
    For j = 0 To UBound(t)
      brr(j, 0) = t(j)
      If InStr(t(j), "]") Then brr(j, 1) = dic(Split(t(j), "]")(0)) Else brr(j, 1) = p
    Next
    For j = 0 To UBound(brr, 1) - 1
      For k = j + 1 To UBound(brr, 1)
        If brr(j, 1) > brr(k, 1) Then
          s = brr(j, 0): brr(j, 0) = brr(k, 0): brr(k, 0) = s
          s = brr(j, 1): brr(j, 1) = brr(k, 1): brr(k, 1) = s
        End If
      Next
      str = str & vbNewLine & brr(j, 0)
    Next
    arr(i, 1) = Mid(str, 3) & vbNewLine & brr(j, 0)
  Next
  [c3].Resize(UBound(arr, 1)) = arr
End Sub

mrshz

一把小刀闯天下 发表于 2020-3-11 15:52
Option Explicit

Sub test()

老师，运行代码，当单元格只有一行内容时，如何在最前方 避免插入 换行符

mrshz

一把小刀闯天下 发表于 2020-3-11 15:52
Option Explicit

Sub test()

老师，当两列数据，存在空白单元格时，能否继续往下运行，而不提示  “错误9，下标越界”

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, s, t, p, dic, str
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a3:b" & [b3].End(xlDown).Row)
  For i = 1 To UBound(arr, 1)
    t = Split(arr(i, 1), Chr(10))
    dic.RemoveAll: p = UBound(t) + 1
    For j = 0 To UBound(t)
      If InStr(t(j), "]") Then dic(Split(t(j), "]")(0)) = j
    Next
    If Len(arr(i, 2)) Then '非空
      t = Split(arr(i, 2), Chr(10)): str = vbNullString
      If UBound(t) > 0 Then '大于1条数据
        ReDim brr(UBound(t), 1)
        For j = 0 To UBound(t)
          brr(j, 0) = t(j)
          If InStr(t(j), "]") Then '有编号
            s = Split(t(j), "]")(0)
            If dic.exists(s) Then '有编号规则
              brr(j, 1) = dic(s)
            Else '有编号无规则排后面
              brr(j, 1) = p
            End If
          Else
            brr(j, 1) = p
          End If
        Next
        For j = 0 To UBound(brr, 1) - 1
          For k = j + 1 To UBound(brr, 1)
            If brr(j, 1) > brr(k, 1) Then
              s = brr(j, 0): brr(j, 0) = brr(k, 0): brr(k, 0) = s
              s = brr(j, 1): brr(j, 1) = brr(k, 1): brr(k, 1) = s
            End If
          Next
          str = str & vbNewLine & brr(j, 0)
        Next
        arr(i, 1) = Mid(str, 3) & vbNewLine & brr(j, 0)
      Else '单条数据直接输出
        arr(i, 1) = arr(i, 2)
      End If
    Else '为空
      arr(i, 1) = vbNullString
    End If
  Next
  [c3].Resize(UBound(arr, 1)) = arr
End Sub