我需要一个不断扩展的Access数据库的大规模循环的帮助，该数据库由大约280.000行数据组成。该过程每周添加3000行数据，因此宏的运行时间仅在增加。完成大约需要一个小时。
完成程序的最佳方法是什么？我对VBA很有经验，但是SQL知识是有限的。
总结的问题是，位于“此处需要的帮助”中的If语句遍历3000家公司的280.000行数据。
目标是在JQHistory中对公司的最新每周评分进行评分，但必须考虑运行宏的日期
注意：除“此处需要帮助”之外的所有内容，我已经在另一个宏中进行了优化。我将其留给希望改善问题的背景。
这是未优化的宏：
Sub OpdaterKvant()
Dim wb As Workbook
Dim ws As Worksheet
Dim DatoIn As Date
Set db = New ADODB.Connection
Set DbEQ = New ADODB.Connection
'The location of the database is determined outside the macro'
strConn = ConnectionString
db.Open strConn
Set wb = Workbooks.Open("My File Location")
Set ws = wb.Worksheets(1)
n = ws.UsedRange.Rows.Count
DateIn = Right(ws.Cells(1, 1), 2) & "-" & Mid(ws.Cells(1, 1), 5, 2) & "-" & Left(ws.Cells(1, 1), 4)
Dato = Format(DateIn, "mm-dd-yyyy")
db.Execute ("DELETE * FROM JQScores")
For i = 3 To n
Sedol = Replace(ws.Cells(i, 1), " ", "")
Company = Left(Replace(ws.Cells(i, 2), "'", ""), Len(Replace(ws.Cells(i, 2), "'", "")) - 1)
Country = Replace(ws.Cells(i, 3), " ", "")
Region = Replace(ws.Cells(i, 4), " ", "")
Sector = Replace(ws.Cells(i, 5), " ", "")
MarketCap = Replace(Replace(ws.Cells(i, 6), " ", ""), ",", ".")
JQRank = Replace(ws.Cells(i, 7), " ", "")
ValueRank = Replace(ws.Cells(i, 8), " ", "")
QualityRank = Replace(ws.Cells(i, 9), " ", "")
MomentumRank = Replace(ws.Cells(i, 10), " ", "")
JQScore = Replace(Replace(ws.Cells(i, 11), " ", ""), ",", ".")
'Inserts the information into the Access database.'
Sql = "Insert into JQScores (Sedol, Company, Region, Sector, MarketCapUSD, JQ_Rank, Value_Rank, Quality_Rank, Momentum_Rank, JQ_Score, Country) VALUES ('" & Sedol & "','" & Company & "', '" & Region & "', '" & Sector & "', " & MarketCap & ", '" & JQRank & "', '" & ValueRank & "', '" & QualityRank & "', '" & MomentumRank & "', " & JQScore & ", '" & Country & "')"
db.Execute (Sql)
'*** HELP NEEDED IN THIS SECTION'
If db.Execute("Select Count(Id) as NumId from JQHistory where Sedol='" & Sedol & "' and history_date=#" & Dato & "#")("NumId") = 0 Then
Sql = "Insert into JQHistory (History_date, Sedol, Selskabsnavn, JQScore, JQ_Rank, Value_Rank, Momentum_Rank, Quality_Rank, Marketcap) VALUES (#" & Dato & "#, '" & Sedol & "','" & Company & "'," & JQScore & ", '" & JQRank & "', '" & ValueRank & "', '" & MomentumRank & "', '" & QualityRank & "', " & MarketCap & ")"
db.Execute (Sql)
Else
Sql = "Update JQHistory set MarketCap=" & MarketCap & ", Selskabsnavn='" & Company & "' , JQ_Rank='" & JQRank & "', Value_Rank='" & ValueRank & "', Quality_Rank='" & QualityRank & "', Momentum_Rank='" & MomentumRank & "', JQScore=" & JQScore & " WHERE SEDOL='" & Sedol & "' and History_Date=#" & Dato & "#"
db.Execute (Sql)
End If
'***'
Next i
db.Close
wb.Close
答案 0 :(得分：0)
最优方法最终使用了DAO.Recordset和DAO.Database选项，并且进行了许多优化调整。
最大的快捷方式是使用'Recordset.FindFirst'来确定是只添加数据（花费22秒）还是更新具有相同日期的数据（花费12分钟）。尽管主要情况是会花费22秒。
耗时12分钟的场景并未得到优化，因为这种情况很少发生。
完整解决方案：
Sub OpdaterKvant()
Dim wb As Workbook
Dim wbOp As Workbook
Dim ws As Worksheet
Dim wsOp As Worksheet
Dim i, n As Integer
Dim db As DAO.Database
Dim rsScores As DAO.Recordset
Dim rsHistory As DAO.Recordset
StartTime = Timer
Call PERFORMANCEBOOST(False)
Set PB = CREATEPROGRESSBAR
With PB
.SetStepCount (4)
.Show
End With
Set wbOp = ThisWorkbook
Set wsOp = wbOp.ActiveSheet
'Step 1: Open JQGCLE
Set wb = Workbooks.Open("Location", ReadOnly:=True)
Set ws = wb.Worksheets(1)
ws.Activate
n = ws.UsedRange.Rows.Count
DateIn = Right(ws.Cells(1, 1), 2) & "-" & Mid(ws.Cells(1, 1), 5, 2) & "-" & Left(ws.Cells(1, 1), 4)
'Step 2: Optag værdier i Excel
PB.Update "Data hentes fra JQGLCE-ark"
ReDim Sedol(3 To n) As String
ReDim Company(3 To n) As String
ReDim Country(3 To n) As String
ReDim Region(3 To n) As String
ReDim Sector(3 To n) As String
ReDim MarketCap(3 To n) As String 'Tal
ReDim MarketCapSQL(3 To n) As String 'Tal
ReDim JQRank(3 To n) As String
ReDim ValueRank(3 To n) As String
ReDim QualityRank(3 To n) As String
ReDim MomentumRank(3 To n) As String
ReDim JQScore(3 To n) As String 'Tal
ReDim JQScoreSQL(3 To n) As String 'Tal
For i = 3 To n
Sedol(i) = Trim(ws.Cells(i, 1))
Company(i) = Left(Replace(ws.Cells(i, 2), "'", ""), Len(Replace(ws.Cells(i, 2), "'", "")) - 0) 'Stod tidligere på minus 1 - Hvorfor?
Country(i) = Trim(ws.Cells(i, 3))
Region(i) = Trim(ws.Cells(i, 4))
Sector(i) = Trim(ws.Cells(i, 5))
MarketCap(i) = ws.Cells(i, 6) 'Til DAO
MarketCapSQL(i) = Replace(ws.Cells(i, 6), ",", ".") 'Til SQL
JQRank(i) = Trim(ws.Cells(i, 7))
ValueRank(i) = Trim(ws.Cells(i, 8))
QualityRank(i) = Trim(ws.Cells(i, 9))
MomentumRank(i) = Trim(ws.Cells(i, 10))
JQScore(i) = ws.Cells(i, 11) 'Til DAO
JQScoreSQL(i) = Replace(ws.Cells(i, 11), ",", ".") 'Til SQL
'DAO og SQL bliver behandlet forskelligt ift. komma
Next i
'Step 3: Indsæt værdier i Access-database
Set acc = New Access.Application
Set db = acc.DBEngine.OpenDatabase("Location", 1, 0)
'Step 3.1: JQScores
PB.Update "JQScores indsættes i databasen"
Set rsScores = db.OpenRecordset(Name:="JQScores", Type:=RecordsetTypeEnum.dbOpenDynaset)
db.Execute "DELETE * FROM JQScores"
For i = 3 To n
With rsScores
.AddNew
!Sedol = Sedol(i)
!Company = Company(i)
!Region = Region(i)
!Sector = Sector(i)
!MarketCapUSD = MarketCap(i)
!JQ_Rank = JQRank(i)
!Value_Rank = ValueRank(i)
!Quality_Rank = QualityRank(i)
!Momentum_Rank = MomentumRank(i)
!JQ_Score = JQScore(i)
!Country = Country(i)
.Update
End With
Next i
rsScores.Close
Set rsScores = Nothing
'Step 3.2: JQHistory
Set rsHistory = db.OpenRecordset(Name:="JQHistory", Type:=RecordsetTypeEnum.dbOpenDynaset)
With rsHistory
If .RecordCount <> 0 Then
i = 3
.FindFirst "History_Date = '" & DateIn & "'"
If .NoMatch = True Then
'Hvis datoen ikke er i datasættet, bliver dataen tilføjet
PB.Update "Hurtig: JQHistory indsættes i databasen"
For i = 3 To n
.AddNew
!History_Date = DateIn
!Sedol = Sedol(i)
!Selskabsnavn = Company(i)
!MarketCap = MarketCap(i)
!JQ_Rank = JQRank(i)
!Value_Rank = ValueRank(i)
!Quality_Rank = QualityRank(i)
!Momentum_Rank = MomentumRank(i)
!JQScore = JQScore(i)
.Update
Next i
Else
'Hvis datoen allerede er der, skal den opdateres
PB.Update "Langsom: JQHistory indsættes i databasen"
For i = 3 To n
db.Execute ("UPDATE JQHistory SET MarketCap=" & MarketCapSQL(i) & ", Selskabsnavn='" & Company(i) & "', JQ_Rank='" & JQRank(i) & "', Value_Rank='" & ValueRank(i) & "', Quality_Rank='" & QualityRank(i) & "', Momentum_Rank='" & MomentumRank(i) & "', JQScore=" & JQScoreSQL(i) & " WHERE SEDOL='" & Sedol(i) & "' and History_Date='" & DateIn & "'")
Next i
End If
End If
End With
rsHistory.Close
Set rsHistory = Nothing
'Step 4: Færdiggørelse
acc.DoCmd.Quit acQuitSaveAll 'Lukker og gemmer database
Set db = Nothing
wsOp.Activate
wsOp.Range("B7").Value = "Seneste data benyttet: " & DateIn
wb.Close SaveChanges:=False
Call PERFORMANCEBOOST(True)
Unload PB
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Opdatering fuldført. Proceduren tog " & MinutesElapsed & "."
End Sub