在Excel中編輯超過100.000行的速度很慢

Question

我有一個.xlsm文件來檢查我的KPI。

數據是從AS400導入的，因此我需要將日期格式從YYYYMMDD設置為DD / MM / YYYY，並且需要檢查例如日期是否在一定范圍內。

對於此操作，我從第二行循環到最后一行，但是代碼需要五分鍾才能運行。

我該如何改善？

Sub FormatDb()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Sheets("db").Select
    Dim avvio As Date
    Dim arresto As Date
    Dim tempo As Date
    avvio = Now

    Dim UR As Long, X As Long
    Dim MyCol As Integer
    MyCol = 1
    UR = Cells(Rows.Count, MyCol).End(xlUp).Row
    For X = 2 To UR
        If Len(Cells(X, "H")) > 1 Then
            Cells(X, "AJ") = CDate(Right(Cells(X, "H"), 2) & "/" & Mid(Cells(X, "H"), 5, 2) & "/" & Left(Cells(X, "H"), 4))
        End If
        If Len(Cells(X, "L")) > 1 Then
            Cells(X, "AK") = CDate(Right(Cells(X, "L"), 2) & "/" & Mid(Cells(X, "L"), 5, 2) & "/" & Left(Cells(X, "L"), 4))
        End If
        If Len(Cells(X, "AC")) > 1 Then
            Cells(X, "AL") = CDate(Right(Cells(X, "AC"), 2) & "/" & Mid(Cells(X, "AC"), 5, 2) & "/" & Left(Cells(X, "AC"), 4))
        End If
            Cells(X, "AM") = Month(Cells(X, "AK"))
             Cells(X, "AQ") = WorkingDays(Cells(X, "AJ"), Cells(X, "AK"))
           If Cells(X, "AQ") >= 4 And Cells(X, "AJ") + 3 <= Cells(X, "AK") Then
                Cells(X, "AN") = "Includi nel KPI"
            Else
                Cells(X, "AN") = "KO"
            End If
            If Cells(X, "AL") = "" Then
                Cells(X, "AO") = "Err"
            Else
                If Cells(X, "AL") <= Cells(X, "AK") Then
                    Cells(X, "AO") = "Win"
                Else
                    Cells(X, "AO") = "Fail"
                End If
            End If
            Cells(X, "AP") = Cells(X, "AO")

            If Cells(X, "AG") = "" Then
                Cells(X, "AR") = Cells(X, "P")
            Else
                Cells(X, "AR") = Cells(X, "AG")
            End If
            Cells(X, "AS") = Cells(X, "P") - Cells(X, "R")
    Next X
    arresto = Now
    tempo = arresto - avvio
    MsgBox "Formattazione e ricalcolo in " & tempo

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Range("A2").Select
End Sub

完整檔案

Answer 1

您的一般問題是您使用工作表存儲臨時值。 不要那樣做 請改用變量。

Option Explicit

Const DTACCE As String = "H"
Const DTSCAD As String = "L"
Const QTRICH As String = "P"
Const QTPROD As String = "R"
Const DTEVEN As String = "AC"
Const QTEVEN As String = "AG"
Const DTCHK1 As String = "AN"  ' Check DTACCE vs DTSCAD
Const DTCHK2 As String = "AO"  ' Check DTSCAD vs DTEVEN
Const DTCHK3 As String = "AP"  ' Check Finale KPI
Const QTEVEN2 As String = "AR" ' QTEVEN_2
Const QTFFFF As String = "AS"  ' ffff

Function YYYYMMDDtoDate(val As String) As Date
  If Len(val) = 8 Then
    YYYYMMDDtoDate = DateSerial(Mid$(val, 1, 4), Mid$(val, 5, 2), Mid$(val, 7, 2))
  End If
End Function

Sub FormatDb()
  Dim c As Range
  Dim x As Long
  Dim avvio As Date, dtAcceVal As Date, dtScadVal As Date, dtEvenVal As Date

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  Set c = Sheets("db").UsedRange
  avvio = Now

  For x = 2 To c.Rows.Count
    dtAcceVal = YYYYMMDDtoDate(c(x, DTACCE).Value)
    dtScadVal = YYYYMMDDtoDate(c(x, DTSCAD).Value)
    dtEvenVal = YYYYMMDDtoDate(c(x, DTEVEN).Value)

    If dtAcceVal <> vbEmpty And dtScadVal <> vbEmpty And dtEvenVal <> vbEmpty Then
      If WorkingDays(dtAcceVal, dtScadVal) >= 4 And dtAcceVal + 3 <= dtScadVal Then
        c(x, DTCHK1).Value = "Includi nel KPI"
      Else
        c(x, DTCHK1).Value = "KO"
      End If

      If dtEvenVal <= dtScadVal Then
        c(x, DTCHK2).Value = "Win"
      Else
        c(x, DTCHK2).Value = "Fail"
      End If

      c(x, DTCHK3).Value = c(x, DTCHK2).Value

      If c(x, QTEVEN) = "" Then
        c(x, QTEVEN2) = c(x, QTRICH)
      Else
        c(x, QTEVEN2) = c(x, QTEVEN)
      End If

      c(x, "AS") = c(x, QTRICH) - c(x, QTPROD)

    ElseIf dtAcceVal = vbEmpty Then
      c(x, DTCHK1).Value = "Err in DTACCE"
    ElseIf dtScadVal = vbEmpty Then
      c(x, DTCHK1).Value = "Err in DTSCAD"
    ElseIf dtEvenVal = vbEmpty Then
      c(x, DTCHK2).Value = "Err in DTEVEN"
    End If
  Next x

  MsgBox "Formattazione e ricalcolo in " & CDate(Now - avvio)

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

Answer 2

使用一個數組，我解決了“時間”問題，現在代碼在00:00:12工作。

Sub FormatDb()
Dim avvio As Date
Dim arresto As Date 'Single
Dim tempo As Date 'Single
Dim UR As Long, X As Long
Dim MyCol As Long
Dim sh As Worksheet
Dim arng As Variant

Application.ScreenUpdating = False
Application.Calculation = xlManual
Set sh = Sheets("db")
avvio = Now()

MyCol = 1
sh.Select
UR = sh.Cells(Rows.Count, MyCol).End(xlUp).Row
ReDim arng(UR, 9) As Variant
For X = 0 To UR
    arng(X, 0) = ConvDate(Cells(X + 2, 8))
    arng(X, 1) = ConvDate(Cells(X + 2, 12))
    arng(X, 2) = IIf(Cells(X + 2, 29) = "", "", ConvDate(Cells(X + 2, 29)))
    arng(X, 3) = Month(arng(X, 1))
    arng(X, 6) = WrkDaysCount(ConvDate(Cells(X + 2, 8)), ConvDate(Cells(X + 2, 12)))
    arng(X, 4) = IIf(arng(X, 6) >= 4 And arng(X, 0) + 3 <= arng(X, 1), "Includi nel KPI", "KO")
    arng(X, 5) = IIf(arng(X, 2) = "", "Err", IIf(arng(X, 2) <= arng(X, 1), "Win", "Fail"))
    arng(X, 7) = IIf(Cells(X + 2, 33) = "", Cells(X + 2, 16), Cells(X + 2, 33))
    arng(X, 8) = Cells(X + 2, 16) - Cells(X + 2, 18)
Next X
sh.Range("AJ2:AS" & UR) = arng
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
arresto = Now() 'Timer
tempo = arresto - avvio
sh.Range("AJ2").Select = Nothing
MsgBox "Formattazione e ricalcolo in " & tempo

結束子

Public Function ConvDate(ByVal sData As String) As Date
ConvDate = CDate(Right(sData, 2) & "/" & Mid(sData, 5, 2) & "/" & Left(sData, 4))
End Function

Public Function WrkDaysCount(StartDate As Date, ByVal EndDate As Date) As Long Dim DayStart As Long Dim DayEnd As Long Dim daytot As Long Dim Nrweeks As Long DayStart = Weekday(StartDate, vbMonday) DayEnd = EndDate - StartDate + DayStart Nrweeks = Int(DayEnd / 7) daytot = DayEnd - (Nrweeks * 2) - DayStart + 1 WrkDaysCount = daytot End Function

Answer 3

這不是對子過程的完全重寫，但我想指出，VBA的TextToColumns方法可以將日期的一列快速解析為另一列。

With ActiveSheet   '<- set this worksheet reference properly!
    With .Cells(1, 1).CurrentRegion
        With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
            .Columns(8).TextToColumns Destination:=.Cells(1, "AJ"), DataType:=xlFixedWidth, FieldInfo:=Array(0, 5)
            .Columns(12).TextToColumns Destination:=.Cells(1, "AK"), DataType:=xlFixedWidth, FieldInfo:=Array(0, 5)
            .Columns(29).TextToColumns Destination:=.Cells(1, "AL"), DataType:=xlFixedWidth, FieldInfo:=Array(0, 5)
            .Columns("AJ:AL").NumberFormat = "dd/mm/yyyy"
        End With
    End With
End With

上面的代碼將YYYYMMDD日期轉換為默認的區域系統日期。 取決於系統默認值，甚至可能不需要數字格式化操作。 我對Len(Cells(X, "H")) > 1標准不清楚。 如果只需要一個值（而不是長度大於1的值），則空白值將不會在目標列中產生任何結果。

這是一個非常快的工作表操作。