Editing more than 100.000 rows in Excel is slow

Question

I have an .xlsm file to check my 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.

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

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

Answer 1

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.

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.

This is a very fast worksheet operation.

Answer 2

using one array I solved the "time" problem, now the code work in 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

Answer 3

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