Wątek przeniesiony 2021-09-16 10:15 z Inne języki programowania przez cerrato.

VBA - optymalizacja kodu

0

Witam.
Na początku może dodam, że zaczynam przygodę z VBA. Poniższy algorytm, jesli zajdą odpowiednie warunki, pobiera dane z Arkusza1, na ich podstawie szuka danych w Arkuszu2 i kopiuje do Arkusza1 brakujace dane. W głównej pętli FOR mamy cztery główne IFy, dodam ze w jednym przebiegu zawsze zostanie spełniony TYLKO jeden główny IF. Algorytm zwraca poprawne wynik, jednak dla dużej ilości danych: ile_A, ile_A1 > 10k, algorytm działa za długo. Prośba o wsparcie w optymalizacji poniższego kodu pod względem szybkości wykonywania.

Dim i As Integer
Dim j As Integer
Dim ile_A As Integer
Dim ile_A1 As Integer
Dim rach1 As String
Dim rach2 As String

ile_A = 2000
ile_A1 = 2000


For i = 2 To ile_A
    If Arkusz1.Cells(i, 1).Value <> "" And Arkusz1.Cells(i, 2).Value = "" And Arkusz1.Cells(i, 3).Value = 0 And Arkusz1.Cells(i, 14).Value = "" Then
    rach1 = Trim(Arkusz1.Cells(i, 1).Value)
        For j = 2 To ile_A1
          rach2 = Trim(Arkusz2.Cells(j, 5).Value)
          If rach1 = rach2 Then
                Arkusz1.Cells(i, 2).Value = Arkusz2.Cells(j, 6).Value
                j = ile_A1
          End If
        Next j
    End If
 
    If Arkusz1.Cells(i, 6).Value <> "" And Arkusz1.Cells(i, 7).Value = "" And Arkusz1.Cells(i, 8).Value = 0 And Arkusz1.Cells(i, 14).Value = "" Then
    rach1 = Trim(Arkusz1.Cells(i, 6).Value)
        For j = 2 To ile_A1
          rach2 = Trim(Arkusz2.Cells(j, 5).Value)
          If rach1 = rach2 Then
                Arkusz1.Cells(i, 7).Value = Arkusz2.Cells(j, 6).Value
                j = ile_A1
          End If
        Next j
    End If

    If Arkusz1.Cells(i, 1).Value = "" And Arkusz1.Cells(i, 2).Value <> "" And Arkusz1.Cells(i, 3).Value = 0 And Arkusz1.Cells(i, 14).Value = "" Then
    rach1 = Trim(Arkusz1.Cells(i, 2).Value)
        For j = 2 To ile_A1
          rach2 = Trim(Arkusz2.Cells(j, 6).Value)
          If rach1 = rach2 Then
                Arkusz1.Cells(i, 1).Value = Arkusz2.Cells(j, 5).Value
                j = ile_A1
          End If
        Next j
    End If

 
    If Arkusz1.Cells(i, 6).Value = "" And Arkusz1.Cells(i, 7).Value <> "" And Arkusz1.Cells(i, 8).Value = 0 And Arkusz1.Cells(i, 14).Value = "" Then
    rach1 = Trim(Arkusz1.Cells(i, 7).Value)
        For j = 2 To ile_A1
          rach2 = Trim(Arkusz2.Cells(j, 6).Value)
          If rach1 = rach2 Then
               Arkusz1.Cells(i, 6).Value = Arkusz2.Cells(j, 5).Value
               j = ile_A1
          End If
        Next j
    End If
Next i


0

Zaproponowałbym jak poniżej. Te For'y zamieniłbym na Do until (elastyczne podejście co do ilości wierszy) jednak brak informacji o danych wejściowych. Zakładam, że oba arkusze są w tym samym pliku Excel'a.

Option Explicit

Sub aaa()
Dim wb As Workbook: Set wb = Workbooks("Zeszyt1.xlsm")
Dim ws1 As Worksheet: Set ws1 = wb.Worksheets("Arkusz1")
Dim ws2 As Worksheet: Set ws2 = wb.Worksheets("Arkusz2")
Dim i As Integer
Dim j As Integer
Dim ile_A As Integer
Dim ile_A1 As Integer
Dim rach1 As String
Dim rach2 As String

Application.ScreenUpdating = False

ile_A = 2000
ile_A1 = 2000
 
For i = 2 To ile_A
    If Len(ws1.Cells(i, 1).Value) <> 0 And Len(ws1.Cells(i, 2).Value) = 0 And ws1.Cells(i, 3).Value = 0 And Len(ws1.Cells(i, 14).Value) = 0 Then
        rach1 = Trim(ws1.Cells(i, 1).Value)
        
        For j = 2 To ile_A1
          rach2 = Trim(ws2.Cells(j, 5).Value)
          
          If rach1 = rach2 Then
                ws1.Cells(i, 2).Value = ws2.Cells(j, 6).Value
                'j = ile_A1
                Exit For
          End If
        Next j
        
    ElseIf Len(ws1.Cells(i, 6).Value) <> 0 And Len(ws1.Cells(i, 7).Value) = 0 And ws1.Cells(i, 8).Value = 0 And Len(ws1.Cells(i, 14).Value) = 0 Then
        rach1 = Trim(ws1.Cells(i, 6).Value)
        
        For j = 2 To ile_A1
          rach2 = Trim(ws2.Cells(j, 5).Value)
          
          If rach1 = rach2 Then
                ws1.Cells(i, 7).Value = ws2.Cells(j, 6).Value
                'j = ile_A1
                Exit For
          End If
        Next j
     
    ElseIf Len(ws1.Cells(i, 1).Value) = 0 And Len(ws1.Cells(i, 2).Value) <> 0 And ws1.Cells(i, 3).Value = 0 And Len(ws1.Cells(i, 14).Value) = 0 Then
        rach1 = Trim(ws1.Cells(i, 2).Value)
        
        For j = 2 To ile_A1
          rach2 = Trim(ws2.Cells(j, 6).Value)
          
          If rach1 = rach2 Then
                ws1.Cells(i, 1).Value = ws2.Cells(j, 5).Value
                'j = ile_A1
                Exit For
          End If
        Next j
 
    ElseIf Len(ws1.Cells(i, 6).Value) = 0 And Len(ws1.Cells(i, 7).Value) <> 0 And ws1.Cells(i, 8).Value = 0 And Len(ws1.Cells(i, 14).Value) = 0 Then
        rach1 = Trim(ws1.Cells(i, 7).Value)
        
        For j = 2 To ile_A1
          rach2 = Trim(ws2.Cells(j, 6).Value)
          
          If rach1 = rach2 Then
               ws1.Cells(i, 6).Value = ws2.Cells(j, 5).Value
               'j = ile_A1
               Exit For
          End If
        Next j
    End If
Next i

Application.ScreenUpdating = True

MsgBox "Koniec"

End Sub

0

Dzięki za odpowiedź.
Oba Arkusze są w tym samym pliku, a wartość zmiennych ile_A i ile_A1 są wcześniej obliczane, tu dla przykładu podałem 2k.

0

Wydaje mi się, że żeby to przyspieszyć to trzeba by było stworzyć Range z danych przefiltrować wg. kryteriów z tych if-ów i pętla obrabiać tylko przefiltrowane rekordy:

https://stackoverflow.com/questions/34032755/vba-filter-on-criteria-and-loop-through-rows

0

Dzięki za podpowiedź, nie miałem wcześniej za bardzo styczności z Range, pora nadrobić zaległości.

1 użytkowników online, w tym zalogowanych: 0, gości: 1