合并数组后，接时间顺序排序

dsyxr903

如图，如何将数组按时间顺序排序？见附件。请老师指教。
非常时期，祝大家身体健康！

microyip

http://club.excelhome.net/thread-1443182-1-1.html 二维（以下）数组排序的自定义函数，参考变通一下

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, sht, dic, s, sum, m
  Set dic = CreateObject("scripting.dictionary")
  sht = Split("流水 消费")
  ReDim brr(1 To 10 ^ 4, 1 To 4)
  With Sheets("汇总")
    s = .[b2].Value: sum = 100
    For i = 0 To 1
      arr = Sheets(sht(i)).[a1].CurrentRegion
      For j = 2 To UBound(arr, 1)
        If arr(j, 6 - i * 2) = s Then
          If Not dic.exists(arr(j, 1)) Then m = m + 1: dic(arr(j, 1)) = m: brr(m, 1) = arr(j, 1)
          brr(dic(arr(j, 1)), i + 2) = brr(dic(arr(j, 1)), i + 2) + arr(j, 5)
        End If
      Next
    Next
    For i = 1 To m - 1
      For j = i + 1 To m
        If brr(i, 1) > brr(j, 1) Then
          For k = 1 To UBound(brr, 2)
            s = brr(i, k): brr(i, k) = brr(j, k): brr(j, k) = s
          Next
        End If
      Next
    Next
    For i = 1 To m
      sum = sum + brr(i, 2) - brr(i, 3): brr(i, 4) = sum
    Next
    .[a:a].NumberFormatLocal = "yyyy/mm/dd"
    With .[a4]
      .Resize(UBound(brr, 1), UBound(brr, 2)).ClearContents
      If m > 0 Then .Resize(m, UBound(brr, 2)) = brr
    End With
  End With
End Sub

dsyxr903

一把小刀闯天下 发表于 2020-1-29 13:27
Option Explicit

Sub test()

正解，谢谢小刀老师。

shenjianrong163

借用microyip（花香鸟语）的数组排序：
Sub 添加银行()
    Dim r%, i%, j%
    Dim d, arr, brr
    Set d = CreateObject("Scripting.dictionary")
    With Worksheets("流水")
        r = .Cells(.Rows.Count, 6).End(xlUp).Row
        arr = .Range("F2:F" & r)
    End With
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = ""
    Next
    brr = d.Keys
    Set d = Nothing
    Worksheets("汇总").Cells(2, 2).Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(brr, ",")
    End With
End Sub


Sub 汇总查询()
    Dim str$, r1%, r2%, i%, j%
    Dim d, arr, brr, crr(), drr
        With Worksheets("汇总")
        str = .Cells(2, 2).Value
        If str = "" Then
            MsgBox "请选择银行！"
            Exit Sub
        End If
    End With
    Set d = CreateObject("Scripting.Dictionary")
    With Worksheets("流水")
        r1 = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("A2:F" & r1)
    End With
    With Worksheets("消费")
        r2 = .Cells(.Rows.Count, 1).End(xlUp).Row
        brr = .Range("A2:F" & r2)
    End With
        For i = 1 To UBound(arr)
          If arr(i, 6) = str Then
            If d.Exists(arr(i, 1)) = False Then
                d(arr(i, 1)) = d.Count + 1
                ReDim Preserve crr(1 To 4, 1 To d.Count)
                crr(1, d.Count) = arr(i, 1)
            End If

                crr(2, d(arr(i, 1))) = crr(2, d(arr(i, 1))) + arr(i, 5)
          End If
        Next

        For i = 1 To UBound(brr)
          If brr(i, 4) = str Then
            If d.Exists(brr(i, 1)) = False Then
                d(brr(i, 1)) = d.Count + 1
                ReDim Preserve crr(1 To 4, 1 To d.Count)
                crr(1, d.Count) = brr(i, 1)
            End If
                crr(3, d(brr(i, 1))) = crr(3, d(brr(i, 1))) + brr(i, 5)
          End If
        Next
        For i = 1 To d.Count
            crr(4, i) = 100 + crr(2, i) - crr(3, i)
        Next

    With Worksheets("汇总")
        .Range("A4:E" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1).ClearContents
        .Range("A4:A" & d.Count + 3).Select
        Selection.NumberFormatLocal = "yyyy/m/d;@"
        .Cells(4, 1).Resize(d.Count, 4) = Application.Transpose(crr)
        drr = .Range("A4:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        drr = VariantSort(drr, 1, True, "/")
        .Cells(4, 1).Resize(d.Count, 4) = drr
    End With
    Set d = Nothing
End Sub


Function VariantSort(ByVal vData As Variant, Optional ByVal nSortCol As Variant, Optional ByVal bValIsStr As Boolean = False, Optional sReplaceToVal As String, Optional ByVal bDownSort As Boolean = False) As Variant   '数组排序
'对二维以下数组排序，nSortCol需要排序的列数，bValIsStr是否按字符串形式比较，sReplaceToVal是替换为空再比较数值的字符串，bDownSort是否降序排序
'返回值说明：
'      Empty：设定排序列数大于数组列数
'      错误信息：数组维数大于2
'      原vData值：非数组
'      数组：已经按要求排序的数组
    Dim nDimension As Integer '维度
    Dim nRow As Double, nCol As Double, vTmp As Variant, nJ As Double, vVal As Variant

    On Error Resume Next
    If IsArray(vData) Then
        For nDimension = 0 To 3
            nRow = UBound(vData, nDimension + 1)
            If Err.Number <> 0 Then Exit For
        Next
    Else
        nDimension = -1 '表示非数组
    End If

    If IsArray(vData) Then '判断是否数组
        On Error Resume Next '考虑需要确定数组维数，使用遇错方式来处理。遇错继续执行下一句
        For nDimension = 0 To 3
            nRow = UBound(vData, nDimension + 1) '获取对应维度数组的最大行数
            If Err.Number <> 0 Then Exit For '遇出错时，表示数组没有nDimension + 1维度
        Next
        On Error GoTo 0 '恢复遇错时进入调试模式

        If nDimension > 2 Then
            vData = "数组维数大于2“"
        ElseIf IsMissing(nSortCol) Then '参数被忽略输入时
            If nDimension = 2 Then nSortCol = LBound(vData, 2) '当维度为2时，默认以第一列为排序对象
        ElseIf nDimension = 2 And nSortCol > UBound(vData, 2) Then '当需要排序的维度大于实际数组维度时
            vData = Empty
        End If
    End If
    If IsArray(vData) Then
        ReDim vVal(1 To 2) '定义数组用于记录需要比较的两个数
        nJ = LBound(vData) '记录起始的行数
        For nRow = LBound(vData) To UBound(vData) - 1 '因需比较当前与下一行数值，所以最大行数只能到UBound(vData) - 1
            If nDimension = 1 Then '维度为1时
                If bValIsStr Then '比较对象是字符串形式比较时
                    If sReplaceToVal = "" Then
                        vVal(1) = CStr(vData(nRow)) '当前行的字符串，强制转换为字符串形式
                        vVal(2) = CStr(vData(nRow + 1)) '下一行的字符串，强制转换为字符串形式
                    Else '需替换指定字符串再进行数值上的比较
                        vVal(1) = Val(Replace(CStr(vData(nRow)), sReplaceToVal, "")) '当前行的字符串替换指定字符串为空后的数值，强制转换为数字形式
                        vVal(2) = Val(Replace(CStr(vData(nRow + 1)), sReplaceToVal, "")) '下一行的字符串替换指定字符串为空后的数值，强制转换为数字形式
                    End If
                Else
                    vVal(1) = vData(nRow)
                    vVal(2) = vData(nRow + 1)
                End If
            Else '维度为2时
                If bValIsStr Then
                    If sReplaceToVal = "" Then
                        vVal(1) = CStr(vData(nRow, nSortCol))
                        vVal(2) = CStr(vData(nRow + 1, nSortCol))
                    Else
                        vVal(1) = Val(Replace(CStr(vData(nRow, nSortCol)), sReplaceToVal, ""))
                        vVal(2) = Val(Replace(CStr(vData(nRow + 1, nSortCol)), sReplaceToVal, ""))
                    End If
                Else
                    vVal(1) = vData(nRow, nSortCol)
                    vVal(2) = vData(nRow + 1, nSortCol)
                End If
            End If
            If (bDownSort And vVal(1) >= vVal(2)) Or (Not bDownSort And vVal(1) <= vVal(2)) Then '符合指定排序时，交换记录已经比较到哪行
                If nRow > nJ Then
                    nJ = nRow
                Else
                    nRow = nJ
                End If
            Else '不符合指定排序时，交换当前行与下一行数值
                If nDimension = 1 Then
                    vTmp = vData(nRow)
                    vData(nRow) = vData(nRow + 1)
                    vData(nRow + 1) = vTmp
                Else
                    For nCol = LBound(vData, 2) To UBound(vData, 2)
                        vTmp = vData(nRow, nCol)
                        vData(nRow, nCol) = vData(nRow + 1, nCol)
                        vData(nRow + 1, nCol) = vTmp
                    Next
                End If
                If nRow <> LBound(vData) Then nRow = nRow - 2
            End If
        Next nRow
    End If
    VariantSort = vData '返回结果
End Function
汇总查询.rar (19.05 KB, 下载次数: 1)

2020-1-29 16:04 上传

点击文件名下载附件
汇总

dsyxr903

shenjianrong163 发表于 2020-1-29 16:04
借用microyip（花香鸟语）的数组排序：
Sub 添加银行()
    Dim r%, i%, j%

感谢shen老师的解答，祝你新年快乐