我有一个.xlsm文件来检查我的KPI。
数据从AS400导入，然后我需要格式化YYYYMMDD到DD / MM / YYYY的日期，我需要检查日期是否在一定范围内。
对于此操作，我从第2行循环到最后一行，但代码需要超过五分钟才能运行。
我该如何改进？
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
答案 0 :(得分：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
答案 1 :(得分：1)
使用一个数组我解决了＆＃34;时间＆＃34;问题，现在代码工作在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
答案 2 :(得分：1)
这不是对子程序的完全重写，但我想指出VBA的TextToColumns method可以快速地将一列日期解析为另一列。
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 的值），那么空值将不会在目标列中产生任何内容。
这是一个非常快速的工作表操作。