含有特殊字条排序问题

haonan6888

各位大神好！

     因工作需要对大量测量数据整理，现碰到排序问题，本人才疏学浅，恳请各位大神帮帮忙，在此感谢！！！
     问题如下：现在附件表的“原始数据表”中需对数据按桩号从小到大排列，升序排列时会出现K0+000.000_1、K0+000.000_11、K0+000.000_12、K0+000.000_2。。。。。。这样的排序结果，如果把K0+000.000_1、K0+000.000_2更改为K0+000.000_01、K0+000.000_02后就可以正常排序。
    所以我想用VBA的方式把K0+000.000_1、K0+000.000_2这样的数据都更改为K0+000.000_01、K0+000.000_02然后进行排序，再K0+000.000_01、K0+020.000_01、K0+040.000_01变化的地方插入一空白行。处理好的数据样本如附件“达到的效果”中。

zpy2

https://club.excelhome.net/forum.php?mod=viewthread&tid=1623110&page=1&mobile&_dsign=24ae670d

liulang0808

Sub ttt()
    Dim brr()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets(1).UsedRange
    For j = 2 To UBound(arr)
        d(Val(Mid(arr(j, 1), 4, 3))) = d(Val(Mid(arr(j, 1), 4, 3))) & "," & j
    Next j
    ReDim brr(1 To UBound(arr) + d.Count, 1 To UBound(arr, 2))
    r = 0
    For j = 1 To d.Count
        x = WorksheetFunction.Small(d.keys, j)
        crr = Split(d(x), ",")
        For i = 1 To UBound(crr)
            m = Val(Split(arr(Val(crr(i)), 1), "_")(1))
            For k = i + 1 To UBound(crr)
                n = Val(Split(arr(Val(crr(k)), 1), "_")(1))
                If n < m Then
                    tm = crr(i)
                    crr(i) = crr(k)
                    crr(k) = tm
                End If
            Next k
        Next i
        For i = 1 To UBound(crr)
            r = r + 1
            For k = 1 To UBound(arr, 2)
                brr(r, k) = arr(Val(crr(i)), k)
            Next k
        Next i
        r = r + 1
    Next j
    Sheets(2).[a2].Resize(r, UBound(arr, 2)) = brr
End Sub

liulang0808

附件内容供参考。。。。。。

haonan6888

zpy2 发表于 2022-5-25 07:25
https://club.excelhome.net/forum.php?mod=viewthread&tid=1623110&page=1&mobile&_dsign=24ae670d

非常感谢！

haonan6888

liulang0808 发表于 2022-5-25 07:40
附件内容供参考。。。。。。

谢谢大神帮助，又帮我减少了好多工作量呀！大神万岁！！！！！！

ykcbf1100

排序。。。。。。。。

ykcbf1100

1. Sub ykcbf()   '//2025.3.14    排序
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set sh = ThisWorkbook.Sheets("2022-05-24_1_横断面 (原始数字)")
   
5.     With sh
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .Range("a2:k" & r)
   
8.     End With
   
9.     For i = 1 To UBound(arr)
   
10.         st = Split(arr(i, 1), "_")
    
11.         arr(i, 10) = st(0)
    
12.         arr(i, 11) = Val(st(1))
    
13.     Next
    
14.     Set sht = ThisWorkbook.Worksheets.Add
    
15.     With sht
    
16.         .Name = "TempSheet"
    
17.         Set Rng = .Range("a1:k" & r - 1)
    
18.         Rng.Value = arr
    
19.         With Rng
    
20.             .Parent.Sort.SortFields.Clear
    
21.             .Sort key1:=.Item(10), order1:=1, key2:=.Item(11), order2:=1, Header:=2
    
22.         End With
    
23.         arr = Rng.Value
    
24.     End With
    
25.     sht.Delete
    
26.     sh.Range("a2:i" & r) = arr
    
27.     Application.DisplayAlerts = True
    
28.     Application.ScreenUpdating = True
    
29. End Sub
    
30. 
    
31. 
    

复制代码

ＥＸＣＥＬ小子

1. Sub SortAndInsertBlanks()
   
2.     Dim ws As Worksheet
   
3.     Dim rng As Range
   
4.     Dim arr As Variant, sortArr() As Variant
   
5.     Dim i As Long, j As Long, k As Long
   
6.     Dim colCount As Integer
   
7.    
   
8.     Set ws = ActiveSheet
   
9.     Set rng = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
   
10.     colCount = rng.Columns.Count
    
11.     arr = rng.Value
    
12.    
    
13.     ' 创建排序辅助数组 [主桩号, 序号, 原始索引]
    
14.     ReDim sortArr(1 To UBound(arr), 1 To 3)
    
15.     For i = 1 To UBound(arr)
    
16.         Dim parts() As String
    
17.         parts = Split(arr(i, 1), "_")
    
18.         sortArr(i, 1) = parts(0)     ' 主桩号部分
    
19.         sortArr(i, 2) = CInt(parts(1)) ' 序号部分
    
20.         sortArr(i, 3) = i             ' 原始行号
    
21.     Next
    
22.    
    
23.     ' 双条件排序（主桩号升序 + 序号升序）
    
24.     For j = 1 To UBound(sortArr) - 1
    
25.         For k = j + 1 To UBound(sortArr)
    
26.             If sortArr(j, 1) > sortArr(k, 1) Or _
    
27.                (sortArr(j, 1) = sortArr(k, 1) And sortArr(j, 2) > sortArr(k, 2)) Then
    
28.                 SwapRows sortArr, j, k
    
29.                 SwapRows arr, j, k
    
30.             End If
    
31.         Next k
    
32.     Next j
    
33.    
    
34.     ' 写入排序结果
    
35.     rng.ClearContents
    
36.     rng.Resize(UBound(arr), colCount) = arr
    
37.    
    
38.     ' 插入空白行（从下往上处理）
    
39.     Application.ScreenUpdating = False
    
40.     Dim lastRow As Long
    
41.     lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
42.    
    
43.     For i = lastRow - 1 To 2 Step -1
    
44.         Dim currStake As String, nextStake As String
    
45.         currStake = Split(ws.Cells(i, 1).Value, "_")(0)
    
46.         nextStake = Split(ws.Cells(i + 1, 1).Value, "_")(0)
    
47.         
    
48.         If currStake <> nextStake Then
    
49.             ws.Rows(i + 1).Insert Shift:=xlDown
    
50.             ' 设置边框（可选）
    
51.             
    
52.         End If
    
53.     Next i
    
54.    
    
55.     Application.ScreenUpdating = True
    
56.    
    
57. End Sub
    
58. 
    
59. ' 辅助函数：交换数组行
    
60. Private Sub SwapRows(targetArray, i As Long, j As Long)
    
61.     Dim temp
    
62.     For x = LBound(targetArray, 2) To UBound(targetArray, 2)
    
63.         temp = targetArray(i, x)
    
64.         targetArray(i, x) = targetArray(j, x)
    
65.         targetArray(j, x) = temp
    
66.     Next
    
67. End Sub
    
68. 
    

复制代码