紧急求助各位如何对不连续的单元格排序

dancefly09

请教各位，我在VBA处理单元格排序时遇到一个问题，如下图所示：
左侧两列的不连续的单元格（凡是不为空的单元格），凡是时间比最晚允许启动时间早的，就把这个启动时间按照日期从小到大的顺序进行排序，对于重复的日期，那个靠上，哪个排前面。把最后的排序结果返回一个Rang对象的数组 。
请各位帮忙看看怎么写VBA代码，非常感谢了。




不连续单元格排序.zip (14.87 KB, 下载次数: 6)

2018-7-13 11:44 上传

点击文件名下载附件

duquancai

排序后的结果，你没模拟。你手工排序模拟出结果看看是什么样子的？两列合成1列，去重复，去空，再排序。。。。。。。。

dancefly09

duquancai 发表于 2018-7-13 12:05
排序后的结果，你没模拟。你手工排序模拟出结果看看是什么样子的？两列合成1列，去重复，去空，再排序。。 ...

排序的结果是一个Arr数组，数组的内容在本地窗口查看时如上图所示

一把小刀闯天下

Option Explicit

Sub test()
  Dim i, j, t, n, row, arr
  row = Cells(Rows.Count, "a").End(xlUp).row
  t = Cells(Rows.Count, "b").End(xlUp).row
  If t > row Then row = t
  arr = Range("a2:b" & row)
  ReDim brr(1 To 2 * UBound(arr, 1))
  For Each t In arr
    If Len(t) > 0 And CDate(t) < CDate([e1]) Then n = n + 1: brr(n) = t
  Next
  For i = 1 To n - 1
    For j = i + 1 To n
      If CDate(brr(i)) > CDate(brr(j)) Then
        t = brr(i): brr(i) = brr(j): brr(j) = t
      End If
  Next j, i
  If n > 0 Then MsgBox Join(brr, vbNewLine)
End Sub

dancefly09

一把小刀闯天下 发表于 2018-7-13 12:27
Option Explicit

Sub test()

非常感谢您，非常感谢。不过可能有点问题，我的描述不是特别清楚，我最后需要的是按照排序的结果，把单元格对象写入到一个Rang数组中，如下这样的：

一把小刀闯天下

'数组名不同而已，再测试一下是否如你所愿

Option Explicit

Sub test()
  Dim i, j, t, n, row, arr
  row = Cells(Rows.Count, "a").End(xlUp).row
  t = Cells(Rows.Count, "b").End(xlUp).row
  If t > row Then row = t
  arr = Range("a2:b" & row)
  ReDim Arr1(1 To 2 * UBound(arr, 1))
  For Each t In arr
    If Len(t) > 0 And CDate(t) < CDate([e1]) Then n = n + 1: Arr1(n) = t
  Next
  For i = 1 To n - 1
    For j = i + 1 To n
      If CDate(Arr1(i)) > CDate(Arr1(j)) Then
        t = Arr1(i): Arr1(i) = Arr1(j): Arr1(j) = t
      End If
  Next j, i
  If n > 0 Then ReDim Preserve Arr1(1 To n): MsgBox Join(Arr1, vbNewLine)
End Sub

duquancai

dancefly09 发表于 2018-7-13 12:38
非常感谢您，非常感谢。不过可能有点问题，我的描述不是特别清楚，我最后需要的是按照排序的结果，把单元 ...

1. Sub main()
   
2.        MsgBox "答案请测试楼下代码！"
   
3. End Sub

复制代码

duquancai

dancefly09 发表于 2018-7-13 12:38
非常感谢您，非常感谢。不过可能有点问题，我的描述不是特别清楚，我最后需要的是按照排序的结果，把单元 ...

1. Option Explicit
   
2. Sub main()
   
3.     Dim n&, r&, i&, j&, crr(), q, g As Range, s$, Arr() As Range, pt As Date, kt As Date, js As Object
   
4.     Set g = Range("a:b").Find("*", , , , 1, 2): If g Is Nothing Then Exit Sub
   
5.     r = g.Row: If r < 2 Then Exit Sub
   
6.     kt = [e1].Value: crr = Range("a1:b" & r)
   
7.     For j = 1 To 2
   
8.         For i = 2 To r
   
9.             If Len(crr(i, j)) Then
   
10.                 pt = CDate(crr(i, j))
    
11.                 If pt < kt Then
    
12.                     n = n + 1
    
13.                     s = s & "," & "[" & "'" & pt & "'" & "," & n & "," & "'" & i & " " & j & "'" & "]"
    
14.                 End If
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     s = "[" & Mid(s, 2) & "]": If n > 0 Then ReDim Arr(1 To n)
    
19.     Set js = CreateObject("MSScriptControl.ScriptControl")
    
20.     js.Language = "JavaScript"
    
21.     js.eval ("a=" & s & ";a.sort(function(x,y){return (new Date(x[0])==new Date(y[0]))?(x[1]-y[1]):(new Date(x[0])-new Date(y[0]))});")
    
22.     For i = 0 To n - 1
    
23.         q = Split(js.eval("a[" & i & "][2]"))
    
24.         Set Arr(i + 1) = Cells(1 * q(0), 1 * q(1))
    
25.         MsgBox Arr(i + 1).Address(0, 0)
    
26.     Next
    
27.     MsgBox IIf(n > 0, "请检查对象数组Arr", "!!!")
    
28. End Sub

复制代码

dancefly09

duquancai 发表于 2018-7-13 23:27
dancefly09 发表于 2018-7-13 12:38
非常感谢您，非常感谢。不过可能有点问题，我的描述不是特别清楚，我 ...

非常感谢非常感谢，正是所需要的。多谢啦。！