如何用VBA来排序 修改记录

870734707

需求根据"修改记录"表中的数据,匹配机器型号后，将计划开工的日期展示在上面的表格中，并按修改日期先后顺序，输入，A，B，C

将ABC写入表中

笨鸟飞不高

猜一个！代码结果与模拟结果有差异！！

870734707

笨鸟飞不高 发表于 2024-8-26 15:05
猜一个！代码结果与模拟结果有差异！！

感谢老师，如果把ABC换成1234，是不是会简单点？

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr()
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("修改记录")
   
7.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
8.         arr = .Range("b3:d" & r)
   
9.         For i = 1 To UBound(arr)
   
10.             If Not d.exists(arr(i, 1)) Then
    
11.                 m = 1
    
12.                 ReDim brr(1 To m)
    
13.             Else
    
14.                 brr = d(arr(i, 1))
    
15.                 m = UBound(brr) + 1
    
16.                 ReDim Preserve brr(1 To m)
    
17.             End If
    
18.             brr(m) = arr(i, 2)
    
19.             d(arr(i, 1)) = brr
    
20.         Next
    
21.     End With
    
22.     With Worksheets("主表")
    
23.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
24.         .Range("f3:ab" & r).ClearContents
    
25.         arr = .Range("b2:ab" & r)
    
26.         For i = 2 To UBound(arr)
    
27.             If d.exists(arr(i, 1)) Then
    
28.                 brr = d(arr(i, 1))
    
29.                 For k = 1 To UBound(brr)
    
30.                     For j = 5 To UBound(arr, 2)
    
31.                         If brr(k) <= arr(1, j) And brr(k) > arr(1, j) - 7 Then
    
32.                             arr(i, j) = Chr(64 + k)
    
33.                             Exit For
    
34.                         End If
    
35.                     Next
    
36.                 Next
    
37.             End If
    
38.         Next
    
39.         .Range("b2:ab" & r) = arr
    
40. 
    
41.     End With
    
42. End Sub
    

复制代码

chxw68

参与一下。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr(), i&, j&, k&, r&, dic As Object, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Worksheets(2).[B2].CurrentRegion.Value
    For i = 2 To UBound(ar)
        dic(ar(i, 1)) = dic(ar(i, 1)) & " " & i
    Next i
    For Each vKey In dic.keys
         br = Split(dic(vKey))
         r = 0: Erase cr
         For j = 1 To UBound(br)
             r = r + 1
             ReDim Preserve cr(1 To 2, 1 To r)
             cr(1, r) = ar(br(j), 2)
             cr(2, r) = ar(br(j), 3)
         Next j
         dic(vKey) = cr
     Next
   
    With Worksheets(1)
        With [B2].CurrentRegion
            .Offset(1, 3).ClearContents
            ar = .Value
            For i = 2 To UBound(ar)
                If dic.exists(ar(i, 1)) Then
                    br = dic(ar(i, 1)): r = 64
                    bSort br, 1, 2, 1, UBound(br, 2), 2
                    r = 64
                    For k = 1 To UBound(br, 2)
                        For j = 5 To UBound(ar, 2)
                            If ar(1, j) >= br(1, k) Then
                                r = r + 1
                                ar(i, j) = Chr(r)
                                Exit For
                            End If
                        Next j
                    Next k
                End If
            Next i
            .Value = ar
        End With
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub
Function bSort(ByRef ar, ByVal iFirst&, ByVal iLast&, ByVal iLeft&, _
    ByVal iRight&, ByVal iKey&, Optional isOrder As Boolean = True)
    Dim i&, j&, k&, vTemp
   
    For i = iLeft To iRight - 1
        For j = iLeft To iRight + iLeft - 1 - i
            If ar(iKey, j) <> ar(iKey, j + 1) Then
                If ar(iKey, j) < ar(iKey, j + 1) Xor isOrder Then
                    For k = iFirst To iLast
                        vTemp = ar(k, j)
                        ar(k, j) = ar(k, j + 1)
                        ar(k, j + 1) = vTemp
                    Next
                End If
            End If
        Next j
    Next i
End Function

gwjkkkkk

参与一下。。。

一招秒杀

埃，为了个一次性的需求写那么多复杂繁琐冗长的宏代码，这哪里有效率，数据多了，位置变了，又要改哪些参数？真是要人老命， 你们真是闲得蛋疼吗？其实这么简单的需求，一个几个函数组合而成的公式就全部搞定了，即时生效，所见即所得。