Question

我正在尝试为excel开发一个VBA宏，它在相当大量的数据中找到一个值（多出现一次）并将此值复制到另一组数据中。我的代码是：

Sub FilasPallet()
Dim k As Long

  Worksheets("Datos").Range("E:F").ClearContents
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  k = 3
  With Worksheets("Datos").Range("L:L")
  While (k < (Worksheets.Count - 1) * 28 * 25)

      Set c = .Find(Worksheets("Datos").Cells(k, 3).Value, SearchDirection:=xlNext, SearchOrder:=xlByColumns, LookIn:=xlValues, LookAt:=xlWhole)
      If Not c Is Nothing Then
          firstAddress = c.Address
          oldpCount = 0
          Do
              pCount = c.Offset(0, 5).Value
              d1 = k + oldpCount
              d2 = k + oldpCount + pCount - 1
              Worksheets("Datos").Range("E" & d1 & ":E" & d2).Value = c.Offset(0, 3).Value
              Worksheets("Datos").Range("F" & d1 & ":F" & d2).Value = c.Offset(0, 4).Value
              If pCount = 25 Then
                GoTo nextiteration
              End If
              oldpCount = oldpCount + pCount
              Set c = .FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstAddress
      Else
        Worksheets("Datos").Range("E" & k & ":E" & k + 24).Value = "No existe pallet"
      End If
nextiteration:
      Set c = Nothing
      k = k + 25

  Wend
  End With
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  MsgBox "Acabado"
End Sub

主要问题是：

Worksheets("Datos").Range("E" & d1 & ":E" & d2).Value = c.Offset(0, 3).Value
Worksheets("Datos").Range("F" & d1 & ":F" & d2).Value = c.Offset(0, 4).Value

因为如果我在代码中调试一行代码，那么这行代码需要花费太多时间来完成这个值的复制。然而，如果我使用这种变化：

Worksheets("Datos").Range("E" & d1 & ":E" & d2) = c.Offset(0, 3).Value
Worksheets("Datos").Range("F" & d1 & ":F" & d2) = c.Offset(0, 4).Value

它工作正常，并且在调试模式下花费的时间很短。但是当我运行整个程序时，尽管它运行速度很快，但它不会复制值。

有人可以改进此代码或给我另一个实现想法吗？

谢谢！

Answer 1

如果遇到同样的麻烦，我终于解决了这个问题。这是使用函数发现密集使运行真的很慢。为了解决这个问题，我已经将范围复制到一个数组中，因为访问内存比访问工作表更快，所以在进行1064次搜索时（在1000个值的范围内）需要不到几秒钟的时间，并且对于每次搜索，我都会粘贴25次字符串。

以下是代码：

Sub FilasPallet()
Dim k As Long
Dim pallets() As Variant
Dim palletname As String

  Worksheets("Datos").Range("E:F").ClearContents
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  With Worksheets("Datos")
  pallets = Application.Transpose(.Range("L1:L2000").Value)
  uB = UBound(pallets)
  lB = LBound(pallets)

  amountData = .Range("C3").End(xlDown).Row
  k = 3
  While (k < amountData)
    palletname = .Cells(k, 3).Value
    oldpCount = 0
    For i = lB To uB
        If pallets(i) = palletname Then
            pCount = .Cells(i, 17).Value
            d1 = k + oldpCount
            d2 = k + oldpCount + pCount - 1
            .Range("E" & d1 & ":E" & d2) = .Cells(i, 15)
            .Range("F" & d1 & ":F" & d2) = .Cells(i, 16)
            oldpCount = oldpCount + pCount
            If oldpCount = 25 Then
                GoTo break
            End If
        End If
    Next i
break:
    If oldpCount <> 25 Then
        .Range("E" & k & ":E" & k + 24).Value = "No existe pallet"
    End If
    k = k + 25
   Wend
  End With

  Application.ScreenUpdating = True
  MsgBox "Completado! Voy a recalcular todas las formulas de la tabla. Puede tardar un poco."
  Application.Calculation = xlCalculationAutomatic
  MsgBox "FIN"
End Sub

VBA在大量数据中分配缓慢

1 个答案: