大神来帮忙！优化数据处理过程，提升执行时间。

mumu2659

测试的时候输入15即可，demo数据整理后会有八十多行二十几列的数据。

mumu2659

ykcbf1100 发表于 2024-1-30 08:14
你最好做个效果图，帮助别人理解
看你的代码，不知道cycleTime1值是从哪来的

新的回复附件里面增加了代码，cycleTime1值是跳对话框输入的，这个demo数据需要输入15。十分感谢！

mumu2659

为了方便理解，我把之前写的效率低的代码也贴进去了，Sub DataCollectionD()可以直接运行，上面的Sub OptimizedDataCollectionD()就是改数组方式的，但是有错误运行不了，我的excell版本是2013，供参考！

ykcbf1100

。。。。。。

不良气息

Sub OptimizedDataCollectionD()
    ' 声明变量
    Dim DataQty As Long
    Dim cycleTimeDelta As Single
    Dim i As Long, j As Long, k, n As Long, x As Long, y As Long
    Dim StartTime As Single
    Dim EndTime As Single
    Dim dataArray() As Variant
    Dim resultArray() As Variant
    Dim StartPaseColumn As Integer
    Dim MaxDataLen As Integer
    Dim numRows As Long
    Dim numCols As Long
    Dim tempArray() As Variant ' 临时数组用于暂存结果
    Dim dic As Object, d As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set d = CreateObject("Scripting.Dictionary")
   
    '数据帧间隔时间长度设置
    cycleTime1 = 15
   
    If cycleTime1 = False Then Exit Sub
    ' 检查数据格式
    If Not Cells(1, 1).Value Like "*Time*" Then
        MsgBox "Data format incorrect!"
        Exit Sub
    End If
   
    ' 开始计时
    StartTime = Timer
   

    ' 获取数据范围并将数据读入数组
    DataQty = Cells(Rows.Count, 2).End(xlUp).Row
    dataArray = Range("A1:B" & DataQty).Value

    ' 初始化变量
    n = 1
    i = 1
    StartPaseColumn = 7  ' 从第一行的第7列开始粘贴数据

    ' 处理数据
    ' 初始化数组大小
    numRows = 1 ' 初始行数
    numCols = 1 ' 初始列数
   
    ReDim tempArray(1 To 1) ' 初始化结果数组
        
    For j = 2 To UBound(dataArray) - 1
        ' 计算时间差
        cycleTimeDelta = Abs(Abs(dataArray(j + 1, 1)) - Abs(dataArray(j, 1)))
        
        If cycleTimeDelta * 1000 > cycleTime1 Then
            ReDim Preserve tempArray(1 To UBound(tempArray) + 1)
            tempArray(UBound(tempArray)) = dataArray(j, 2)
            dic(dic.Count) = tempArray
            ReDim tempArray(1 To 1)
            d("A" & j + 1) = True
        Else
            ReDim Preserve tempArray(1 To UBound(tempArray) + 1)
            tempArray(UBound(tempArray)) = dataArray(j, 2)
        End If
    Next j
    ReDim Preserve tempArray(1 To UBound(tempArray) + 1)
    tempArray(UBound(tempArray)) = dataArray(j, 2)
    dic(dic.Count) = tempArray
    ReDim resultArray(1 To dic.Count + 1, 1 To 1)
    j = 1
    For Each k In dic.Keys
        j = j + 1
        tempArray = dic(k)
        If UBound(tempArray) - 1 > UBound(resultArray, 2) Then ReDim Preserve resultArray(1 To UBound(resultArray), 1 To UBound(tempArray) - 1)
        For i = 2 To UBound(tempArray)
            resultArray(j, i - 1) = tempArray(i)
        Next
    Next
    For j = 1 To UBound(resultArray, 2)
        resultArray(1, j) = "#" & j
    Next
    Cells(1, "G").Resize(UBound(resultArray, 1), UBound(resultArray, 2)).Value = resultArray
    Dim rng As Range
    Set rng = Cells(2, 1)
    Set rng = Union(rng, Range(Join(d.Keys, ",")))
    rng.Interior.Color = 65535
   
   
   
    ' 结束计时
    EndTime = Timer

    ' 显示处理行数和执行时间
    MsgBox " 让您久等了！" & vbCrLf & vbCrLf & "本次处理了 " & DataQty & " 行数据，" & vbCrLf & vbCrLf & "总共花费了: " & Format(EndTime - StartTime, "0.00") & " 秒。", vbInformation
   
    ' 自动调整列宽
    ActiveSheet.Columns.AutoFit
   

End Sub

gwjkkkkk

没看懂啊 ！

mumu2659

不良气息 发表于 2024-1-30 16:17
Sub OptimizedDataCollectionD()
    ' 声明变量
    Dim DataQty As Long

相当好用，快到不可思议，太牛了！