Оптимизация цикла через базу данных доступа - PullRequest
Новая
       6

Оптимизация цикла через базу данных доступа

1 голос
/ 13 июня 2019

Мне нужна помощь с массивным циклом в постоянно расширяющейся базе данных Access, состоящей из приблизительно 280 000 строк данных. Процедура добавляет 3000 строк данных каждую неделю, и поэтому время выполнения макросов только увеличивается. Это займет около часа.

Каков оптимальный способ завершить мою процедуру? У меня есть опыт работы с VBA, но знание SQL ограничено.

Обобщенная проблема заключается в том, что оператор If, расположенный в «Справке, необходимой здесь», проходит через 280 000 строк данных для 3000 компаний.

Цель состоит в том, чтобы в 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

1 Ответ

0 голосов
/ 14 июня 2019

Оптимальный способ в конечном итоге заключался в использовании параметров 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
...