Question

我正在为您提供宏的代码，并希望有人能告诉我是什么让我的宏变慢，并为我提供了如何让它运行得更快的解决方案。目前执行此代码需要约1分钟才能完成，但我仍需要改善执行时间，任何帮助都将受到高度赞赏。以下是代码：

Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim query As String
Dim Fond As String
Dim KontoNr As String
Dim StartDate As Date
Dim EndDate As Date
Dim wb As Workbook

  Dim wr As Worksheet
  Dim ws As Worksheet
  Dim wt As Worksheet


Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

  Set wb = ActiveWorkbook
  Set wr = Sheets("Fee")
  Set ws = Sheets("TestExecution")
  Set wt = Sheets("Results_Overview")



  'wr.UsedRange.Interior.ColorIndex = 0
  With wr.UsedRange
    RowCount = .Rows.Count
    If (RowCount > 1) Then
    wr.Range(2 & ":" & RowCount).EntireRow.Delete
    End If
  End With


  With wt.UsedRange
    RowCount = .Rows.Count
    If (RowCount > 2) Then
    wt.Range(2 & ":" & RowCount).EntireRow.Delete
    End If
  End With

  With ws.UsedRange
  ws.Range(Cells(2, 1), Cells(.Rows.Count, 1)).ClearContents
  ws.Range(Cells(2, 6), Cells(.Rows.Count, 15)).ClearContents

  End With


  Dim r As Long
  Dim Count As Integer
  Dim a As Integer
  Dim Counter As Integer



Set con = New ADODB.Connection
Set rs = New ADODB.Recordset


PeriodStartDate = ws.Cells(2, 4).Value
PeriodEndDate = ws.Cells(3, 4).Value
KontoNr = ws.Cells(4, 4).Value

Count = DatePart("d", PeriodEndDate)


strCon = "Provider=SQLOLEDB; " & _
        "Data Source= XXX;" & _
        "Initial Catalog=XX;" & _
        "Integrated Security=SSPI"

con.Open (strCon)
query = "SELECT distinct Fond FROM RI_Trans_Akt ta WITH (NOLOCK) WHERE cast(ta.Avslutsdag as date) < '" & PeriodEndDate & "'"
rs.Open query, con, adOpenStatic
con.Execute query
Counter = rs.RecordCount
ws.Cells(2, 1).CopyFromRecordset rs
rs.Close
con.Close


Dim p As Long
Dim lp As Long
For p = 2 To Counter + 1
StartDate = ws.Cells(2, 4).Value
a = wr.Range("A" & wr.Rows.Count).End(xlUp).Row
For r = 1 To Count

Fond = ws.Cells(p, 1).Value
wr.Cells(a + r, 1).Value = Fond
wr.Cells(a + r, 2).Value = StartDate
wt.Cells(a + r, 1).Value = Fond
wt.Cells(a + r, 2).Value = StartDate
DateFormat = Format(StartDate, "yyyymmdd")


con.Open (strCon)
query = "select Totalt_Antal_Andelar,Forvaltnings_avgift,CAST(Forvaltnings_avgift_kurs AS NUMERIC(30,10)) AS Forvaltnings_avgift_Kurs from ri_fond_avgift WITH (NOLOCK) where Datum = '" & StartDate & "' and Fond = '" & Fond & "'"
rs.Open query, con
con.Execute query
If (rs.RecordCount > 0) Then
wr.Cells(a + r, 3).Value = rs.Fields(0)
wr.Cells(a + r, 4).Value = rs.Fields(1)
wr.Cells(a + r, 5).Value = rs.Fields(2)
Else
wr.Cells(a + r, 3).Value = "0.00"
wr.Cells(a + r, 4).Value = "0.00"
wr.Cells(a + r, 5).Value = "0.00"
End If
rs.Close


query = "SELECT ta.KontoNr,Sum (Antal_andelar) FROM RI_Trans_Akt ta WITH (NOLOCK) WHERE ta.Kontonr = '" & KontoNr & "' and cast(ta.Avslutsdag as date) < '" & StartDate & "' and ta.Fond = '" & Fond & "' and ta.Mak_dag is null Group BY ta.Kontonr,ta.Fond"
rs.Open query, con, adOpenStatic
con.Execute query
If (rs.RecordCount > 0) Then
wr.Cells(a + r, 6).Value = rs.Fields(0)
wr.Cells(a + r, 7).Value = rs.Fields(1)
Else
wr.Cells(a + r, 7).Value = "0.00"
End If
rs.Close

con.Close

StartDate = DateAdd("d", 1, StartDate)

Next r

Dim i As Integer
For i = a + 1 To Count + a
If (wr.Cells(i, 3).Value <> 0) Then
wr.Cells(i, 8).Value = wr.Cells(i, 5).Value * wr.Cells(i, 7).Value
wt.Cells(i, 3).Value = wr.Cells(i, 8).Value

Else
wr.Cells(i, 5).Value = "0.00"
wr.Cells(i, 8).Value = "0.00"
wt.Cells(i, 3).Value = "0.00"
End If

Next i

Dim j As Integer
Dim totalManagementFee As Double
totalManagementFee = 0
For j = a + 1 To Count + a
totalManagementFee = totalManagementFee + wr.Cells(j, 8).Value
Next j
ws.Cells(p, 7).Value = totalManagementFee
ws.Cells(p, 6).Value = Fond

Next p

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True

End Sub

Answer 1

好的，所以你正在读取和写入范围，你应该这样做一次而不是循环。此外，逐个删除行将花费很多时间，您不需要这样做。使用数组，首先将范围转换为数组，然后首先在数组上执行所有验证和操作等，一旦完成，只需将数组粘贴到范围内即可。

将范围更改为数组只需执行以下操作：

Dim i, j As Long
Dim arr() As Variant
Dim rng As Range

Set rng = Worksheet.Range("A1:B10") 'define your range as you wish
arr = rng.Value

'access all cell values inside the array now
For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
        'do whatever you want to do in the array
    Next j
Next i

'paste back the new values to the range
rng.Value = arr

您也使用不同的函数运行相同的查询两次： rs.Open query，con，adOpenStatic＆＃39;返回记录集 con.Execute query＆＃39;不返回记录集

删除第二行，你不需要它

您不止一次地打开和关闭同一个连接，就像您需要在执行任何SQL查询之前打开连接一次并在结束时关闭它。

con.open
' run all sql queries, no need to close the connection unless you have a very specific purpose for it 
con.close
set con=nothing

也不是循环遍历记录集，而是将数据转储到数组中然后循环遍历数组，它更快更稳定：

array = recordset.GetRows(Rows, Start, Fields )

如何提高我的VBA宏代码的执行速度？

1 个答案: