Elektroda.pl
Elektroda.pl
X
Proszę, dodaj wyjątek dla www.elektroda.pl do Adblock.
Dzięki temu, że oglądasz reklamy, wspierasz portal i użytkowników.

Excel - VBA - tablica. Dlaczego te kody nie działają?

05 Lip 2010 00:41 3190 6
  • Poziom 8  
    Hej,

    Piszę w VBA makro, które ma mi pouzupełniać braki danych w kolumnach A i B. W tych kolumnach mam daty (kolumna A) oraz ceny akcji z tych dat (kolumna B). Daty nie są ciągłe (czyli np. po 4 kwietnia mam od razu 7 kwietnia itp.) i próbuję je uzupełnić, tak żeby w miejsca brakujące wstawić daty z poprzedniego dnia (czyli np. dla 5 i 6 kwietnia miałbym dane z 4 kwietnia). Z pomocą forumowiczów napisałem następujące makro:

    Code:

    Sub row_influx()

    Dim i As Long
    i = 2

    Do Until ActiveSheet.Range("A" & i) = "" Or ActiveSheet.Range("A" & i + 1) = ""
        If Range("A" & i).Value = Range("A" & i + 1).Value + 1 Then
          i = i + 1
        Else
          Dim how_many As Integer
          Dim count As Integer
          how_many = Range("A" & i).Value - Range("A" & i + 1).Value - 1
         
          Range(Cells(i + 1, 1), Cells(i + 10000, 2)).Cut Destination:=Range(Cells(i + 1 + how_many, 1), Cells(i + how_many + 10000, 2))
       
          For count = 1 To how_many
            Range("A" & i + count).Value = Range("A" & i).Value - count
            Range("B" & i + count).Value = Range("B" & i + how_many + 1).Value
           
          Next count

          i = i + how_many + 1
        End If
    Loop

    End Sub


    Okazało się jednak, że gdy zgromadzę w jednym pliku 20 takich makr w osobnych arkuszach, to czas działania makra wydłuża się dramatycznie. W związku z tym postanowiłem zastosować tablice zamiast zwykłego makra, żeby zminimalizować kontakt VBA z arkuszem i przyspieszyć działanie programu. I tu pojawiły się schody, bo kody, które piszę nijak nie chcą działać (chcę by działały tak, jak przytoczone wyżej makro). Stanąłem na:

    Code:

    Sub row_influx()

    Dim i As Long
    Dim first As Long
    Dim last As Long
    Dim dimension As Long

    last = Range("A2").Value

    Range("A1").Select
    Selection.End(xlDown).Select
    first = Selection.Value

    dimension = last - first + 1

    Dim Table() As Variant
        ReDim Table(dimension, 2)
        Table = Range(Cells(2, 1), Cells(dimension + 1, 2)).Value
       
    Dim Transposed() As Variant
    ReDim Transposed(2, UBound(Table))
    Dim l As Long
        For l = LBound(Table) To UBound(Table)
          Transposed(1, l) = Table(l, 1)
          Transposed(2, l) = Table(l, 2)
        Next l

    For i = LBound(Table) To UBound(Table) - 1
        If Table(i, 1) <> Table(i + 1, 1) + 1 Then
          Dim how_many As Long
          Dim count As Long
          Dim k As Long
          k = 0
               
          how_many = Table(i, 1) - Table(i + 1, 1) - 1

          For k = 0 To UBound(Table) - i - how_many
            Transposed(1, i + how_many + k) = Transposed(1, i + k)
            Transposed(2, i + how_many + k) = Transposed(2, i + k)
          Next k
         
          For count = 1 To how_many
            Transposed(1, i + count) = Transposed(1, i) - count
            Transposed(2, i + count) = Transposed(2, i + how_many + 1)
          Next count

        End If
    Next i

    End Sub


    Niestety nie działa. Byłbym wdzięczny za sugestie :).

    Dla lepszego zrozumienia problemu załączam arkusz z surowymi danymi.

    Pozdrawiam
  • Moderator Programowanie
    Po co komplikujesz sobie życie?
    Code:
    Sub row_influx()
    
    Start = Timer
    Application.ScreenUpdating = False

    Dim i As Long
    i = 2

    Do Until ActiveSheet.Range("A" & i) = "" Or ActiveSheet.Range("A" & i + 1) = ""
        i = i + 1
        If Range("A" & i - 1).Value <> Range("A" & i).Value + 1 Then
            Range("A" & i).EntireRow.Insert
            Range("A" & i) = Range("A" & i - 1) - 1
            Range("B" & i) = Range("B" & i + 1)
        End If
    Loop

    Meta = Timer
    Application.ScreenUpdating = True
    MsgBox "trwało " & Meta - Start
    End Sub


    Excel - VBA - tablica. Dlaczego te kody nie działają?

    Przyznam szczerze, tego fragmentu
    Żelazny napisał:
    Okazało się jednak, że gdy zgromadzę w jednym pliku 20 takich makr w osobnych arkuszach
    nie rozumiem...
  • Poziom 8  
    Wszystko ładnie, pięknie, tylko gdy w komórkach C i D, F i G itd. mam znowu 'Date' i 'Price' tylko dla innych akcji, i tak x20 (20 par 'Date' i 'Price' dla różnych akcji), i dla każdego C i D, F i G itd. napiszę osobne makro 'row_influx', to wszystko zaczyna cholernie wolno działać mimo braku odświeżania. Stąd pomysł tablicy...
  • Poziom 40  
    Stworzyłem jedno makro dla wielu kolumn (dopóki są dane) opierając się na pomyśle kolegi adamas_nt jednak rzeczywiście przy 20 tabelach z danymi obliczenia trwają znacznie znacznie znacznie dłużej. U mnie :
    Excel - VBA - tablica. Dlaczego te kody nie działają?

    Przy czym jedną tabelę przy innych programach otwartych robił mi w:
    Excel - VBA - tablica. Dlaczego te kody nie działają?

    Code:
    Sub row_influx2()
    
    Start = Timer
    Application.ScreenUpdating = False

    Dim i As Long
    i = 2
    j = 1

    Do Until ActiveSheet.Cells(i, j) = ""

        Do Until ActiveSheet.Cells(i, j) = "" Or ActiveSheet.Cells(i + 1, j) = ""
            i = i + 1
                If Cells(i - 1, j).Value <> Cells(i, j).Value + 1 Then
                    Range(Cells(i, j), Cells(i, j + 1)).Insert Shift:=xlDown
                    Cells(i, j) = Cells(i - 1, j) - 1
                    Cells(i, j + 1) = Cells(i + 1, j + 1)
                End If
        Loop
    i = 2
    j = j + 2
    Loop

    Meta = Timer
    Application.ScreenUpdating = True
    MsgBox "trwało " & Meta - Start
    End Sub


    Osobiście mam wątpliwości czy z tabelami będzie szybciej przecież ilość pętli i przesunięć będzie taka sama więc na czym można zaoszczędzić?
  • Poziom 8  
    Będzie szybciej, bo przy makrze, które stosowaliśmy Excel przy każdej luce w datach dodaje wartości i przesuwa zakresy danych i ma co najmniej dwa kontakty z arkuszem. Dla całej kolumny (nie wspominając już o 20) tych kontaktów będzie całkiem pokaźna ilość, a z tego co wiem, to właśnie podczas pobierania danych z arkusza i powtórnego wrzucania ich (to nazywam kontaktem z arkuszem) VBA traci najwięcej czasu. Tablica spowodowałaby, że VBA miałby tylko 2 kontakty z arkuszem dla każdej kolumny, co wydatnie zwiększyłoby szybkość działania całego makra.
  • Pomocny post
    Moderator Programowanie
    Żelazny napisał:
    20 par 'Date' i 'Price' dla różnych akcji)
    Trza było tak od razu :)

    :arrow: Marek003
    Spróbowałem po Twojemu. Swoją drogą: dlaczego obrabianie pojedynczej kolumny trwa sekundę a tej samej kolumny, tym samym makrem z zapisanymi 39 innymi kolumnami trwa siedem razy dłużej? Być może jest to problem z jakimś obszarem pamięci lub Link. Wpadłem więc na to, że wykorzystam funkcję z przekazywaniem Nr kolumny zamiast zapętlać. Przetestowałem też różne pętle i doszedłem do tego, że w tym przypadku For-Next działa nieco szybciej.

    Wynik (niezbyt imponujący):

    Excel - VBA - tablica. Dlaczego te kody nie działają?

    Sprawdziłem też sposób z przepisywaniem z tablicy do tablicy i jak można było przypuszczać efekt nie jest rewelacyjny, choć o prawie 50% lepszy. I tu mnie tknęło: a gdyby tak kopiować po dwie kolumny do arkusza tymczasowego, przetwarzać (najszybciej wychodziło ze wstawianiem wierszy) i na powrót kopiować do źródłowego?
    Code:
    Sub row_influx3()
    
    Start = Timer
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    arkTmp = ActiveSheet.Name
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Temp"
    Sheets(arkTmp).Activate

    For k = 1 To 256 Step 2
        If Cells(1, k) = "" Then Exit For
        Range(Columns(k), Columns(k + 1)).Copy Sheets("Temp").Columns("A:B")
       
        With Sheets("Temp")
        i = 2
       
        Do Until .Range("A" & i) = "" Or .Range("A" & i + 1) = ""
            i = i + 1
            If .Range("A" & i - 1).Value <> .Range("A" & i).Value + 1 Then
                .Range("A" & i).EntireRow.Insert
                .Range("A" & i) = .Range("A" & i - 1) - 1
                .Range("B" & i) = .Range("B" & i + 1)
            End If
        Loop
       
        .Columns("A:B").Copy Sheets(arkTmp).Range(Columns(k), Columns(k + 1))
        End With
    Next

    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
    Meta = Timer
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "trwało " & Meta - Start
    End Sub
    I wynik dla 40 kolumn

    Excel - VBA - tablica. Dlaczego te kody nie działają?
  • Poziom 8  
    Działa :D I co ważniejsze działa stosunkowo szybko. Dzięki za ten pomysł z kopiowaniem do osobnego arkusza - tablica okazała się zbędna :)