Question

我一直在寻找网络和论坛，但是似乎找不到解决我问题的方法。

我有一张包含此数据的表：

修改了密码

我有此代码：

Sub HorariosReal()

    Dim LastRow As Long, Horario As String, i As Long, arr1 As Variant, a As Long, arrFichajes() As String, _
    arrFinal() As String, Valor1 As Single, Valor2 As Single, x As Long, y As Long, Done As Boolean

    Set YaHecho = New Scripting.Dictionary

    'Primero metemos en un array la gente con horario
    LastRow = ws2.Range("A1").End(xlDown).Row
    arr1 = ws2.Range("A2:A" & LastRow).Value2

    'Convertimos a valores los datos de fichajes y los reemplazamos
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    With ws.Range("F2:J" & LastRow)
        .FormulaR1C1 = "=IFERROR(VALUE(RC[-5]),RC[-5])"
        .Value = .Value
        .Cut Destination:=ws.Range("A2")
    End With

    'Miramos si tiene programación
    With ws.Range("F2:F" & LastRow)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-4],Horarios!C1:C37,MATCH(Fichajes!RC[-5],Horarios!R1C1:R1C37,0),FALSE),""No aparece en programación"")"
        .Value = .Value
    End With

    'metemos los datos en un array
    ReDim arrFichajes(2 To LastRow, 1 To 6)
    ReDim arrFinal(2 To LastRow, 1 To 5)
    For i = 2 To UBound(arrFichajes, 1)
        For a = 1 To UBound(arrFichajes, 2)
            arrFichajes(i, a) = ws.Cells(i, a)
            If a = 3 Or a = 4 Then arrFichajes(i, a) = Format(ws.Cells(i, a), "hh:mm")
            If a = 5 Then
                Valor1 = Application.Round(ws.Cells(i, a), 2)
                arrFichajes(i, a) = Valor1
            End If
        Next a
    Next i

    x = 2
    y = 2
    For i = 2 To UBound(arrFichajes, 1)            
        Horario = arrFichajes(i, 3) & "-" & arrFichajes(i, 4)
        Valor1 = arrFichajes(i, 5)
        Done = CompruebaDiccionario(arrFichajes(i, 1) & arrFichajes(i, 2))
        If Done Then
            arrFinal(Llave, 3) = arrFinal(Llave, 3) & "/" & Horario
            Valor1 = arrFinal(Llave, 5)
            Valor2 = arrFichajes(i, 5)
            Valor1 = Valor1 + Valor2
            arrFinal(Llave, 5) = Valor1
        Else
            arrFinal(x, 1) = arrFichajes(i, 1)
            arrFinal(x, 2) = arrFichajes(i, 2)
            arrFinal(x, 3) = Horario
            arrFinal(x, 4) = arrFichajes(i, 6)
            arrFinal(x, 5) = Valor1
            YaHecho.Add y, arrFinal(x, 1) & arrFinal(x, 2)
            y = y + 1
            x = x + 1
        End If
    Next i

    ws.Range("A2:E" & LastRow).ClearContents
    ws.Range("A2:E" & UBound(arrFinal, 2)).Value = arrFinal

    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    With ws.Range("F2:F" & LastRow)
        .FormulaR1C1 = "=IFERROR(VALUE(RC[-1]),RC[-1])"
        .Value = .Value
        .Cut Destination:=ws.Range("E2")
    End With

End Sub

添加了此功能以遍历字典：

Function CompruebaDiccionario(Ejemplo As String) As Boolean

    Dim Key As Variant
    For Each Key In YaHecho.Keys
        If YaHecho(Key) = Ejemplo Then
            CompruebaDiccionario = True
            Llave = Key
            Exit For
        End If
    Next Key    

End Function

这些ID只是一个示例，但事实是，一个ID（B列）可以在同一天（A列）具有多个条目（C和D列）。

这是来自工作人员的数据，其工作的入站（C列）和出场数据（D列），我需要将同一天同一位工人的所有条目合并到一行（在C列），然后在D栏找到他的时间表。

该代码可以正常运行，但是非常慢。我注意到，如果我继续停止代码，它的运行速度会更快（这可能吗？）。

我决定使用数组，因为这是一个星期，它有35k +行，但结束还需要一段时间。

我要问的是我的代码中是否有什么错误会减慢该过程。任何帮助将不胜感激。

谢谢！

编辑：

在使用此子程序之前，我正在使用该子程序：

Sub AhorroMemoria(isOn As Boolean)

    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = False

End Sub

Answer 1

这是我的答案，我终于设法使它起作用了！我没有使用字典，而是应该使用字典。

这是最终的代码，在3秒内处理了35,000行，在18秒内处理了153k行。

Sub HorariosReal()

    Dim LastRow As Long, Horario As String, i As Long, arr1 As Variant, a As Long, arrFichajes As Variant, _
    arrFinal() As String, Valor1 As Single, Valor2 As Single, x As Long, y As Long, Done As Long

    Set YaHecho = New Scripting.Dictionary

    'Primero metemos en un array la gente con horario
    LastRow = ws2.Range("A1").End(xlDown).Row
    arr1 = ws2.Range("A2:A" & LastRow).Value2

    'Convertimos a valores las fechas de programación
    i = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
    x = i - 6
    With ws2.Range(ws2.Cells(1, i + 2), ws2.Cells(1, i + 1 + x))
        .FormulaR1C1 = "=VALUE(RC[-" & x + 1 & "])"
        .Value = .Value
        .Cut Destination:=ws2.Cells(1, 7)
    End With

    'Convertimos a valores los datos de fichajes y los reemplazamos
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    With ws.Range("F2:J" & LastRow)
        .FormulaR1C1 = "=IFERROR(VALUE(RC[-5]),RC[-5])"
        .Value = .Value
        .Cut Destination:=ws.Range("A2")
    End With


    'Comprobamos si el DNI está en la primera columna
    If ws2.Range("A1") <> "DNI" Then
        ws2.Columns(3).Cut
        ws2.Columns(1).Insert Shift:=xlToRight
    End If

    'Miramos si tiene programación
    With ws.Range("F2:F" & LastRow)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-4],Horarios!C1:C37,MATCH(Fichajes!RC[-5],Horarios!R1C1:R1C37,0),FALSE),""No aparece en programación"")"
        .Value = .Value
    End With

    'metemos los datos en un array
    ReDim arrFinal(1 To LastRow, 1 To 5)
    arrFichajes = ws.Range("A2:F" & LastRow)

    x = 1
    y = 1
    For i = 1 To UBound(arrFichajes, 1)
        Horario = Format(arrFichajes(i, 3), "hh:mm") & "-" & Format(arrFichajes(i, 4), "hh:mm")
        Valor1 = arrFichajes(i, 5)
        Done = YaHecho.Exists(arrFichajes(i, 1) & arrFichajes(i, 2))
        If Done <> 0 Then
            Done = YaHecho(arrFichajes(i, 1) & arrFichajes(i, 2))
            arrFinal(Done, 3) = arrFinal(Done, 3) & "/" & Horario
            Valor1 = arrFinal(Done, 5)
            Valor2 = arrFichajes(i, 5)
            Valor1 = Valor1 + Valor2
            arrFinal(Done, 5) = Valor1
        Else
            arrFinal(x, 1) = Int(arrFichajes(i, 1))
            arrFinal(x, 2) = arrFichajes(i, 2)
            arrFinal(x, 3) = Horario
            arrFinal(x, 4) = arrFichajes(i, 6)
            arrFinal(x, 5) = Valor1
            YaHecho.Add Key:=arrFinal(x, 1) & arrFinal(x, 2), Item:=y
            y = y + 1
            x = x + 1
        End If
        Done = 0
    Next i

    ws.Range("A2:F" & LastRow).ClearContents
    ws.Range("A2:E" & UBound(arrFinal, 1)).Value = arrFinal

    'Tenemos que arreglar las horas y fechas que se quedan como texto
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    With ws.Range("G2:G" & LastRow) 'horas
        .FormulaR1C1 = "=IFERROR(VALUE(RC[-2]),RC[-2])"
        .Value = .Value
        .Cut Destination:=ws.Range("E2")
    End With

    With ws.Range("G2:G" & LastRow) 'fechas
        .FormulaR1C1 = "=IFERROR(VALUE(RC[-6]),RC[-6])"
        .Value = .Value
        .Cut Destination:=ws.Range("A2")
    End With

End Sub

谢谢大家的评论和帮助！

编辑：在填充arrFichajes数组时使用EvR注释进行编辑

Answer 2

真的只是评论，但您可以替换此过程：

'Convertimos a valores los datos de fichajes y los reemplazamos
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
With ws.Range("F2:J" & LastRow)
    .FormulaR1C1 = "=IFERROR(VALUE(RC[-5]),RC[-5])"
    .Value = .Value
    .Cut Destination:=ws.Range("A2")
End With

以及带有Sub的所有类似代码，例如：

Sub ConvertToValues(rng As Range)
    With rng
        .Value = .Parent.Evaluate("=IFERROR(VALUE(" & .address(false, false) & ")," _
                                              & .address(false, false) & ")")
    End With
End Sub

并拨打类似电话：

LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ConvertToValues ws.Range("F2:J" & LastRow)

这将减少主Sub的大小并消除重复。

加快阵列循环VBA Excel的速度

2 个答案: