时间戳

首页 > 解决方案 > 数据点之间的时间差增加

excel - 数据点之间的时间差增加

问题描述

我正在尝试制作一个宏来增加数据点之间的时间，作为自动数据处理的一部分，但目前它需要的时间太长了。

我的一个传感器每 10 秒记录一个数据点，我想将此 dt 增加到 1 小时。为此，我编写了一些非常简单（低效）的代码（见下文），它们确实有效，但需要 10-40 分钟来处理 1 周的数据，这远非理想。

我已经看到关于使用数组的半相似问题的建议，但是我对此有 0 经验，不知道它是否适用于这个目标。

    Do While Cells(row + 1, 2).Value <> ""
        If Cells(row + 1, 2).Value - Cells(row, 2).Value < 1 / 24.05 Then
            Rows(row + 1).Select
            Selection.Delete Shift:=xlUp
        Else
            row = row + 1
        End If

    Loop

编辑：

我用@Damian 的代码的稍微编辑的版本解决了我的问题，如下所示。

Sub Change_dt()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False


    Dim target As Single
    target = Sheets("Controller").Cells(16, 9).Value
    Dim arrSource As Variant
    With ThisWorkbook.Sheets("Raw data")
        arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array

        Dim finalArr As Variant
        ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))

        .Cells.Delete 'will clean the worksheet

        Dim i As Long, x As Long, j As Long, Z As Long
        x = 1
        Z = 1
        For i = 1 To UBound(arrSource)
            On Error Resume Next
            If arrSource(i + Z, 1) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end  the loop once the next row is empty
            On Error GoTo 0
            'If the next row substracted the first is greater than target both will be copied to the final array
            If arrSource(i + Z, 1) - arrSource(i, 1) > target Then
                For j = 1 To UBound(arrSource, 2)
                    finalArr(x, j) = arrSource(i, j)
                    finalArr(x + 1, j) = arrSource(i + Z, j)
                Next j
                x = x + 2 'increment 2 on x because you wrote 2 lines
                i = i + Z
                Z = 1
            Else
                Z = Z + 1
            End If

        Next i

        'paste the resulting array back to the sheet
        .Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr

        'eliminate the extra unused rows
        i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
        .Rows(i & ":" & .Rows.Count).Delete

    End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

标签： excelvba

解决方案

这应该对您的执行时间有很大帮助：

Sub Change_dt()
    Dim target As Single
    target = Sheets("Controller").Cells(16, 9).Value
    Dim arrSource As Variant
    With ThisWorkbook.Sheets("Raw data")
        arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array

        Dim finalArr As Variant
        ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))

        .Cells.Delete 'will clean the worksheet

        Dim i As Long, x As Long, j As Long
        x = 1
        For i = 5 To UBound(arrSource)
            On Error Resume Next
            If arrSource(i + 1, 2) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end  the loop once the next row is empty
            On Error GoTo 0
            'If the next row substracted the first is greater than 1/24.05 both will be copied to the final array
            If Not arrSource(i + 1, 2) - arrSource(i, 2) < target Then
                For j = 1 To UBound(arrSource, 2)
                    finalArr(x, j) = arrSource(i, j)
                    finalArr(x + 1, j) = arrSource(i + 1, j)
                Next j
                x = x + 2 'increment 2 on x because you wrote 2 lines
            End If

        Next i

        'paste the resulting array back to the sheet
        .Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr

        'eliminate the extra unused rows
        i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
        .Rows(i & ":" & .Rows.Count).Delete

    End With

End Sub

推荐阅读