Question

Не могли бы вы помочь мне оптимизировать макрос, он занимает более 50 минут, но все еще не увенчался успехом.

Цикл For l oop до 1,0 миллиона + строк.
Экран мигает.

Я пробовал Application.ScreenUpdating = True, но это все еще мерцает и для l oop занимает очень много времени.

Я загружаю отчеты с sharepoint и проверяю файл за последние 7 дней.

Имена файлов:

Fsplit2 = "Промежуточный инвентаризационный контроль - все состояния" и формат (сейчас - i, "mmddyy") & "v1.xlsx"

F4 = «Экспорт инвентаря» и формат (сейчас i, «гггг-мм-дд») и «AM.xlsm»

Начиная с f4, я обновляю значения в Fsplit2 на основе имени группы и условий, указанных ниже в коде .

Sub DownloadPastInterimTracker()
    Dim myURL As String
    Dim f1 As String
    Dim f2 As String
    Dim WinHttpReq As Object


    Fsplit1 = "https://share.antheminc.com/projects/Facets-Mig/Plan/Interim%20Inventory%20Tracker/"

     'File handles upto 7 days
   For i = 1 To 7
            Fsplit2 = "Interim Inventory Tracker - All States " & Format(Now - i, "mmddyy") & " v1.xlsx"
             myURL = Fsplit1 & Fsplit2
           Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
           WinHttpReq.Open "GET", myURL, False
          WinHttpReq.Send

          If WinHttpReq.Status = 200 Then
             Set oStream = CreateObject("ADODB.Stream")
             oStream.Open
            oStream.Type = 1
            oStream.Write WinHttpReq.ResponseBody
            oStream.SaveToFile ("C:\Users\AG47552\Desktop\Interim Tracker\Yesterday's Tracker File\" & Fsplit2 & " ")
            oStream.Close
            i = 7

            MsgBox " File Downloaded Successfully  "
        End If   
Next i

Call OpenInterimTracker(Fsplit2)
Call CentralLookup(Fsplit2)
Call NortheastLookup(Fsplit2)
Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Save
Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Close
Call DownloadTableauTracker(Fsplit2)

End Sub

Sub OpenInterimTracker(ByVal Fsplit2 As String)

    Application.DisplayAlerts = False
    Application.ScreenUpdating = True

    Dim sPath As String, sFile As String
    Dim wb As Workbook
    Application.ScreenUpdating = True
    sPath = "C:\Users\AG47552\Desktop\Interim Tracker\Yesterday's Tracker File\"
    sFile = sPath & Fsplit2
    Set wb = Workbooks.Open(sFile)

End Sub

Sub CentralLookup(ByVal Fsplit2 As String)

Dim rnge as Range
Dim cl As range


Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Activate
Worksheets("Central").Activate
lastrow = range("A" & Rows.Count).End(xlUp).Row

   For i = 2 To lastrow
      If Application.WorksheetFunction.IsNA(range("g" & i).Value) Then
         range("g" & i).Value = "Change"
      End If

     If range("g" & i).Value = "Change" Then
        srchval = Trim(range("d" & i).Value)
        chgval = Trim(range("e" & i).Value)

            Workbooks(Fsplit2).Activate
            Sheets("Main Data input").Activate
            On Error Resume Next
             get_row_number = Workbooks(Fsplit2). _
                              Sheets("Main Data input").range("D:D").Find( _
              What:=srchval, _
              LookIn:=xlValues, _
              LookAt:=xlPart, _
              SearchOrder:=xlByColumns, _
              SearchDirection:=xlNext, _
              MatchCase:=True _
              ).Row

        If get_row_number = "" Then
            'do nothing
        Else
            Workbooks(Fsplit2).Activate
            Sheets("Main Data input").range("H" & get_row_number).Value = chgval
            chgval = ""
            chgval.Interior.Color = vbGreen
        End If
        Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Activate
        Worksheets("Central").Activate
     End If
    Next i
End Sub

Sub NortheastLookup(ByVal Fsplit2 As String)

Dim rnge as Range
Dim cl As range


Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Activate
Worksheets("Northeast").Activate
lastrow = range("A" & Rows.Count).End(xlUp).Row

   For i = 2 To lastrow
      If Application.WorksheetFunction.IsNA(range("g" & i).Value) Then
         range("g" & i).Value = "Change"
      End If

     If range("g" & i).Value = "Change" Then
        srchval = Trim(range("d" & i).Value)
        chgval = Trim(range("e" & i).Value)

            Workbooks(Fsplit2).Activate
            Sheets("Main Data input").Activate
            On Error Resume Next
             get_row_number = Workbooks(Fsplit2). _
                              Sheets("Main Data input").range("D:D").Find( _
              What:=srchval, _
              LookIn:=xlValues, _
              LookAt:=xlPart, _
              SearchOrder:=xlByColumns, _
              SearchDirection:=xlNext, _
              MatchCase:=True _
              ).Row

        If get_row_number = "" Then
            'do nothing
        Else
            Workbooks(Fsplit2).Activate
            Sheets("Main Data input").range("H" & get_row_number).Value = chgval
            chgval = ""
            chgval.Interior.Color = vbGreen
        End If
        Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Activate
        Worksheets("Central").Activate
       End If
    Next i
End Sub

Sub DownloadTableauTracker(ByVal Fsplit2 As String)

    Dim myURL As String
    Dim f1 As String
    Dim f2 As String
    Dim f3 As String
    Dim f4 As String

    Dim WinHttpReq As Object

    f1 = "https://share.antheminc.com/sites/EET-Migrations/Migrations%20Tracker/Migrations_Tracker%20_Tableau/"
    f2 = "" & Year(Date) & "/"
    f3 = "" & Format(Now, "mm mmm yyyy") & "/"

    For i = 0 To 2

    f4 = "Inventory Export " & Format(Now - i, "yyyy-mm-dd") & " AM.xlsm"

           myURL = f1 & f2 & f3 & f4
           Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
           WinHttpReq.Open "GET", myURL, False
          WinHttpReq.Send

          If WinHttpReq.Status = 200 Then
             Set oStream = CreateObject("ADODB.Stream")
             oStream.Open
            oStream.Type = 1
            oStream.Write WinHttpReq.ResponseBody
            oStream.SaveToFile ("C:\Users\AG47552\Desktop\Interim Tracker\Tableau Tracker\" & f4 & " ")
            oStream.Close
            i = 5

            MsgBox " Tableau Inventory file downloaded "
        End If     
Next i
Call TableauInventoryOpen(f4)
Call FetchTableauStatus(Fsplit2, f4)
End Sub

Sub TableauInventoryOpen(ByVal f4 As String)

    Application.DisplayAlerts = False
    Application.ScreenUpdating = True

    Dim sPath As String, sFile As String
    Dim wb As Workbook
    Application.ScreenUpdating = True
    sPath = "C:\Users\AG47552\Desktop\Interim Tracker\Tableau Tracker\"
    sFile = sPath & f4
    Set wb = Workbooks.Open(sFile)

End Sub

Sub FetchTableauStatus(ByVal Fsplit2 As String, ByVal f4 As String)

Workbooks(Fsplit2).Activate
Worksheets("Main Data input").Activate
lastrow = range("b" & Rows.Count).End(xlUp).Row

   For i = 3 To lastrow

            srchval = Trim(range("d" & i).Value)
            'chgval = Trim(Range("e" & i).Value)

            Workbooks(f4).Activate
            Sheets("Inventory Export").Activate
            On Error Resume Next
             get_row_number = Workbooks(f4). _
                              Sheets("Inventory Export").range("G:G").Find( _
              What:=srchval, _
              LookIn:=xlValues, _
              LookAt:=xlPart, _
              SearchOrder:=xlByColumns, _
              SearchDirection:=xlNext, _
              MatchCase:=True _
              ).Row

             If get_row_number = "" Then
                'do nothing
             Else
          'Finalize Product and Admin Selections

               Workbooks(f4).Activate
               If Sheets("Inventory Export").range("z" & get_row_number).Value = "Complete" Then
                  Workbooks(Fsplit2).Activate
                  Worksheets("Main Data input").Activate
                  If Sheets("Main Data input").range("O" & i).Value = "Incomplete" Or _
                     Sheets("Main Data input").range("o" & i).Value = "Incomplete with Issues" Then
                     Sheets("Main Data input").range("o" & i).Value = "Complete"
                  End If
                End If
           'Implementation Case Status
                  copyval = ""
                  Workbooks(f4).Activate
                If Sheets("Inventory Export").range("o" & get_row_number).Value = "Implementation Completed" Or _
                   Sheets("Inventory Export").range("o" & get_row_number).Value = "NULL" Then
                    'do nothing
                Else
                    Workbooks(f4).Activate
                    copyval = Sheets("Inventory Export").range("o" & get_row_number).Value
                  Workbooks(Fsplit2).Activate
                  Worksheets("Main Data input").Activate
                  Sheets("Main Data input").range("j" & i).Value = copyval
               End If
           'E&B Audit Complete
               Workbooks(f4).Activate
               If Sheets("Inventory Export").range("r" & get_row_number).Value = "Complete" Then
                  Workbooks(Fsplit2).Activate
                  Worksheets("Main Data input").Activate
                  If Sheets("Main Data input").range("l" & i).Value = "Incomplete" Or _
                     Sheets("Main Data input").range("l" & i).Value = "Incomplete with Issues" Then
                     Sheets("Main Data input").range("l" & i).Value = "Complete"
                  End If
                End If
             End If
        Workbooks(Fsplit2).Activate
                  Worksheets("Main Data input").Activate
     Next i

Workbooks(f4).Close
Workbooks(Fsplit2).Saveas "C:\Users\AG47552\Desktop\Interim Tracker\Today's Tracker File\" & Fsplit2 & " "
End Sub

Оптимизация кода VBA. Обновление занимает более 50 минут.

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

Ответы [ 0 ]

Оптимизация кода VBA. Обновление занимает более 50 минут.

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

Ответы [ 0 ]

Нет похожих вопросов