在Excel中编辑超过100.000行的速度很慢

I have an .xlsm file to check my KPI.

我有一个.xlsm文件来检查我的KPI。

The data is imported from AS400, then I need to format some dates from YYYYMMDD to DD/MM/YYYY and I need to check, for example, whether the date is within a certain range.

数据从AS400导入,然后我需要格式化从YYYYMMDD到DD / MM / YYYY的一些日期,我需要检查,例如,日期是否在一定范围内。

For this operations I loop from 2nd to last row, but the code needs over five minutes to run.

对于此操作,我从第2行循环到最后一行,但代码需要超过五分钟才能运行。

How can I improve it?

我怎样才能改进它?

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

complete file

3 个解决方案

#1

Your general problem is that you use the Worksheet to store temporary values. Don't do that. Use variables instead.

您的一般问题是您使用工作表来存储临时值。不要那样做。改用变量。

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

#2

using one array I solved the "time" problem, now the code work in 00:00:12.

使用一个数组我解决了“时间”问题,现在代码工作在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

End Sub

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

Public Function WrkDaysCount(StartDate As Date,ByVal EndDate As Date)As 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

#3

This is not a full rewrite of the sub procedure but I wanted to point out that VBA's TextToColumns method can parse a column of dates quickly into another column.

这不是对子过程的完全重写,但我想指出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

The above converts the YYYYMMDD dates to default regional system dates. The number formatting operation may not even be necessary depending upon your system defaults. I'm a little unclear on the Len(Cells(X, "H")) > 1 criteria. If you just want a value (not a value with a length greater than 1) then blank values would not produce anything in the destination column.

以上将YYYYMMDD日期转换为默认的区域系统日期。根据您的系统默认值,甚至可能不需要数字格式化操作。我对Len(细胞(X,“H”))> 1标准有点不清楚。如果您只想要一个值(不是长度大于1的值),那么空值将不会在目标列中产生任何内容。

This is a very fast worksheet operation.

这是一个非常快速的工作表操作。