【发布时间】：2018-11-08 15:24:27
【问题描述】：
我一直在寻找网络和这个论坛，但我似乎无法找到解决问题的方法。
我有一张包含这些数据的表格：
编辑代码
我有这个代码：
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
【问题讨论】：
-
这可能是Code Review 的问题，如果代码已经有效。
-
不要通过循环加载数组。一次加载整个：
arrFichajes = ws.Range(ws.Cells(2,1),ws.Cells(Lastrow,4)).Value然后循环直接对数组中的值进行更改。 -
On Error Resume Next-- 你确定可以安全地忽略该循环中的所有错误吗？这可能掩盖了问题的根源。 -
Application.Match正在杀死你。您正在对工作表进行重复的、后期绑定的查找。使用Dictionary创建您自己的查找表并改用这些查找表 - 它的效率要高得多，并且可以避免 ton 的 Excel 开销。 This Code Review answer 更详细一点。 -
您可以从“全尺寸”数组开始并为每个数组保留一个计数器：完成后，您可以将它们缩小到合适的大小，而不是反复重新调整输出数组。此外，如果您将数组下限设为 1 而不是零，这将使您的代码更容易理解。重复的
Find()是性能杀手，也是字典查找的另一个候选者。