Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
Przesunięty przez: Artik
07-01-2019, 15:23
Optymalizacja makra
Autor Wiadomość
mancia14 
Exceloholic


Pomógł: 2 razy
Posty: 179
Wysłany: 07-01-2019, 10:37   Optymalizacja makra

Cześć!

W załączniku macie plik z makrem, które kopiuje dane z wybranych przeze mnie kolumn z arkusza ("Materialy") do arkusza ("Arkusz1").
Makro działa w pętli i martwi mnie, że przy ok. 12 000 wierszy na moim komputerze wykonuje się ok 10 sek. Docelowo danych będzie dużo więcej i szukam sposobu na przyspieszenie procesu.

Nie proszę o gotowe rozwiązanie, potrzebuje podpowiedzi jak można to wykonać. Może powinienem odejść od pętli? Tylko jak nie pętla to co?

Z góry dziękuję za podpowiedzi ;)

lista elementów.xlsm
Pobierz Plik ściągnięto 30 raz(y) 887.83 KB

ID posta: 359887 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 335 razy
Posty: 1785

Wysłany: 07-01-2019, 11:36   

Kod:
Option Explicit
Option Compare Text

Sub kopiuj()
Dim lw As Integer, start As Single, koniec As Single, i As Integer, x As Integer
Dim wsM As Worksheet, wsA As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
start = Timer

Set wsM = Sheets("Materialy")
Set wsA = Sheets("Arkusz1")

lw = wsM.Cells(Rows.Count, 1).End(xlUp).Row

For i = 7 To lw
    x = i - 6
    wsA.Cells(x, 1) = wsM.Cells(i, 1)
    wsA.Cells(x, 2) = wsM.Cells(i, 4)
    wsA.Cells(x, 3) = wsM.Cells(i, 9)
    wsA.Cells(x, 4) = wsM.Cells(i, 11)
Next i

koniec = Timer
MsgBox Format(koniec - start, "0.00")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Na moim rupieciu - było: 2,28, jest: 1,66 sek.
.
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
Ostatnio zmieniony przez umiejead 07-01-2019, 11:39, w całości zmieniany 1 raz  
ID posta: 359892 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1214 razy
Posty: 3598
Wysłany: 07-01-2019, 11:38   

Witaj. Przetestuj moją poprawkę makra. Czas zdecydowanie krótszy
Kod:
Sub kopiuj_kuma()
    Application.ScreenUpdating = False
    Dim koniec As Single, start As Single
    Dim i As Long, lw As Long
    Dim a(), rws()
   
    start = Timer
    With Sheets("materialy")
        lw = .Cells(Rows.Count, 1).End(xlUp).Row
        a = .Range("A7:K" & lw).Value
        ReDim rws(1 To lw)
    End With
    For i = 1 To lw
        rws(i) = i
    Next
    With Sheets("Arkusz1")
        .UsedRange.ClearContents
        .[A1].Resize(lw, 4) = Application.Index(a, Application.Transpose(rws), Array(1, 4, 9, 11))
    End With
    koniec = Timer
    MsgBox Format(koniec - start, "0.00")
End Sub
Pozdrawiam.
ID posta: 359893 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 335 razy
Posty: 1785

Wysłany: 07-01-2019, 11:54   

Ano zdecydowanie: 0,3 - 0,4 sek. :clap
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 359896 Skopiuj do schowka
 
 
Tajan


Pomógł: 4351 razy
Posty: 9667
Wysłany: 07-01-2019, 16:48   

Zwracam uwagę, że funkcja Transpose, którą w swoim kodzie użył kuma ma w VBA ograniczenie wielkości tablicy do 65 536 elementów. Być może to zbyt mała wielkość dla autora pytania. Lecz nic nie stoi na przeszkodzie aby od razu zadeklarować odpowiednią tablicę, bez potrzeby jej transponowania (przy okazji skorygowałem drobne błędy w wyliczaniu wielkości tablicy i obszaru docelowego):
Kod:
Sub kopiuj_tajan()
    Application.ScreenUpdating = False
    Dim koniec As Single, start As Single
    Dim rwCount As Long
    Dim i As Long, lw As Long
    Dim a(), rws()
   
    start = Timer
    With Sheets("materialy")
        lw = .Cells(Rows.Count, 1).End(xlUp).Row
        a = .Range("A7:K" & lw).Value
        rwCount = UBound(a)
        ReDim rws(1 To rwCount, 1 To 1)
    End With
    For i = 1 To rwCount
        rws(i, 1) = i
    Next
    With Sheets("Arkusz1")
        .UsedRange.ClearContents
        .[A1].Resize(rwCount, 4) = Application.Index(a, rws, Array(1, 4, 9, 11))
    End With
    koniec = Timer
    MsgBox Format(koniec - start, "0.00")
End Sub
Może, nawet, będzie trochę szybciej :-)

EDIT Doczytałem, że funkcja Index ma również podobne ograniczenie. Zatem, kod i tak dla obszaru powyżej 65 536 wierszy nie zadziała. A może autorowi wystarczy?
ID posta: 359919 Skopiuj do schowka
 
 
Mentor82 
świeżak


Pomógł: 2 razy
Posty: 8
Wysłany: 07-01-2019, 17:40   

Cześć,
Zastanowiłbym się nad redeklaracją zmiennych z integer na long - to oczywiście zależne ile planujesz mieć danych w skoroszycie. Moja propozycja jest taka, aby cale tabele z obu skoroszytów zaciągnąć do tablic (1 linijka kodu na ładowanie 1 całej tablicy z arkusza do tablicy) , aktualizowanie danych w tablicy a następnie zwrócenie całej drugiej tablicy do arkusza (1 linijka kodu). Wtedy nie wywołujesz prawie w ogóle obiektów i twoje makro będzie zasuwo nawet na kilkuset tysiącach danych. Mogę Ci pomóc z napisaniem takiego kodu, ale potrzebowałbym, abyś zamieścił plik ze strukturą danych.


---
Nie wiem z jakiego sprzętu korzystasz - ale pierwsze słowo twoim poście wskazuje na to że masz możliwość używania znaków diakrytycznych - więc pisz po polsku.
umiejead

edycja Zbiniek:
POPRAWIŁEM ZA CIEBIE.
_________________
Pozdrawiam,
Seba

"Giva a man a fish and you feed him for a day. Teach a man to fish and you feed him for a lifetime."
ID posta: 359920 Skopiuj do schowka
 
 
Tajan


Pomógł: 4351 razy
Posty: 9667
Wysłany: 08-01-2019, 11:27   

Proponuję nieco inne rozwiązanie. Po prostu dane kopiować całymi kolumnami. Nie będzie to szybsze od kopiowania całości obszaru, ale czas działania powinien być raczej zadowalający.
Kod:
Sub kopiuj1()
Dim lw As Long, i As Long
Dim start As Single, koniec As Single
Dim kol As Long
Dim kolArr
Dim kolRng As Range

start = Timer

lw = Sheets("materialy").Cells(Rows.Count, 1).End(xlUp).Row

kolArr = [{1, 4, 9, 11}] 'kolumny do kopiowania


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For i = 1 To UBound(kolArr)
    kol = kolArr(i)
    With Sheets("Materialy")
         Set kolRng = .Range(.Cells(7, kol), .Cells(lw, kol))
    End With
    Sheets("Arkusz1").Cells(1, i).Resize(kolRng.Count).Value = kolRng.Value
Next i

koniec = Timer
MsgBox Format(koniec - start, "0.00")

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

ID posta: 359971 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1214 razy
Posty: 3598
Wysłany: 08-01-2019, 15:05   

A może jednak tablice. Tym razem bez Application.Index() z wykorzystaniem jednej tablicy.
Kod:
Sub kopiuj_kuma2()
    Dim koniec As Single, start As Single
    Dim i As Long, lw As Long
    Dim a()
   
    Application.ScreenUpdating = False
    start = Timer
    With Sheets("materialy")
        lw = .Cells(Rows.Count, 1).End(xlUp).Row
        a = .Range("A7:K" & lw).Value
    End With
    For i = 1 To UBound(a)
        a(i, 2) = a(i, 4)
        a(i, 3) = a(i, 9)
        a(i, 4) = a(i, 11)
    Next
    With Sheets("Arkusz1")
        .UsedRange.ClearContents
        .[A1].Resize(UBound(a), 4) = a
    End With
    koniec = Timer
    MsgBox Format(koniec - start, "0.00")
End Sub
Pozdrawiam.
ID posta: 359986 Skopiuj do schowka
 
 
Tajan


Pomógł: 4351 razy
Posty: 9667
Wysłany: 08-01-2019, 16:49   

Na moim sprzęcie wychodzi, że metoda kopiowania kolumnami jest nieco szybsza od metody wykorzystującej tablice.
ID posta: 359993 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1214 razy
Posty: 3598
Wysłany: 08-01-2019, 16:59   

I tutaj muszę się z Tobą zgodzić :-> .
Pozdrawiam.
ID posta: 359995 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 335 razy
Posty: 1785

Wysłany: 08-01-2019, 18:15   Porównanie szybkości kodów - kopiwanie między arkuszami

Oryginał -mancia14:
Kod:
Option Explicit
Option Compare Text

Sub kopiuj()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lw As Integer, start As Single, koniec As Single, i As Integer, x As Integer
start = Timer
lw = Sheets("materialy").Cells(Rows.Count, 1).End(xlUp).Row
x = 1
For i = 7 To lw
    With Sheets("Arkusz1")
        .Cells(x, 1) = Sheets("Materialy").Cells(i, 1)
        .Cells(x, 2) = Sheets("Materialy").Cells(i, 4)
        .Cells(x, 3) = Sheets("Materialy").Cells(i, 9)
        .Cells(x, 4) = Sheets("Materialy").Cells(i, 11)
    End With
    x = x + 1
Next i
koniec = Timer
MsgBox Format(koniec - start, "0.00")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

2,28 sek.
---------------------------------------------
umiejead:
Kod:
Option Explicit
Option Compare Text

Sub kopiuj()
Dim lw As Integer, start As Single, koniec As Single, i As Integer, x As Integer
Dim wsM As Worksheet, wsA As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
start = Timer

Set wsM = Sheets("Materialy")
Set wsA = Sheets("Arkusz1")

lw = wsM.Cells(Rows.Count, 1).End(xlUp).Row

For i = 7 To lw
    x = i - 6
    wsA.Cells(x, 1) = wsM.Cells(i, 1)
    wsA.Cells(x, 2) = wsM.Cells(i, 4)
    wsA.Cells(x, 3) = wsM.Cells(i, 9)
    wsA.Cells(x, 4) = wsM.Cells(i, 11)
Next i

koniec = Timer
MsgBox Format(koniec - start, "0.00")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
1,66 sek
----------------------------------------------------------
kuma:
Kod:
Sub kopiuj_kuma()
    Application.ScreenUpdating = False
    Dim koniec As Single, start As Single
    Dim i As Long, lw As Long
    Dim a(), rws()
   
    start = Timer
    With Sheets("materialy")
        lw = .Cells(Rows.Count, 1).End(xlUp).Row
        a = .Range("A7:K" & lw).Value
        ReDim rws(1 To lw)
    End With
    For i = 1 To lw
        rws(i) = i
    Next
    With Sheets("Arkusz1")
        .UsedRange.ClearContents
        .[A1].Resize(lw, 4) = Application.Index(a, Application.Transpose(rws), Array(1, 4, 9, 11))
    End With
    koniec = Timer
    MsgBox Format(koniec - start, "0.00")
End Sub
0,33 sek.
---------------------------------------------------
Tajan:
Kod:
Sub kopiuj_tajan()
    Application.ScreenUpdating = False
    Dim koniec As Single, start As Single
    Dim rwCount As Long
    Dim i As Long, lw As Long
    Dim a(), rws()
   
    start = Timer
    With Sheets("materialy")
        lw = .Cells(Rows.Count, 1).End(xlUp).Row
        a = .Range("A7:K" & lw).Value
        rwCount = UBound(a)
        ReDim rws(1 To rwCount, 1 To 1)
    End With
    For i = 1 To rwCount
        rws(i, 1) = i
    Next
    With Sheets("Arkusz1")
        .UsedRange.ClearContents
        .[A1].Resize(rwCount, 4) = Application.Index(a, rws, Array(1, 4, 9, 11))
    End With
    koniec = Timer
    MsgBox Format(koniec - start, "0.00")
End Sub
0,31 sek.
------------------------------------------------
Tajan2:
Kod:

Sub kopiuj1()
Dim lw As Long, i As Long
Dim start As Single, koniec As Single
Dim kol As Long
Dim kolArr
Dim kolRng As Range

start = Timer

lw = Sheets("materialy").Cells(Rows.Count, 1).End(xlUp).Row

kolArr = [{1, 4, 9, 11}] 'kolumny do kopiowania


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For i = 1 To UBound(kolArr)
    kol = kolArr(i)
    With Sheets("Materialy")
         Set kolRng = .Range(.Cells(7, kol), .Cells(lw, kol))
    End With
    Sheets("Arkusz1").Cells(1, i).Resize(kolRng.Count).Value = kolRng.Value
Next i

koniec = Timer
MsgBox Format(koniec - start, "0.00")

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

0,18 sek.
-------------------------------------------------------
Kuma2:
Kod:
Sub kopiuj_kuma2()
    Dim koniec As Single, start As Single
    Dim i As Long, lw As Long
    Dim a()
   
    Application.ScreenUpdating = False
    start = Timer
    With Sheets("materialy")
        lw = .Cells(Rows.Count, 1).End(xlUp).Row
        a = .Range("A7:K" & lw).Value
    End With
    For i = 1 To UBound(a)
        a(i, 2) = a(i, 4)
        a(i, 3) = a(i, 9)
        a(i, 4) = a(i, 11)
    Next
    With Sheets("Arkusz1")
        .UsedRange.ClearContents
        .[A1].Resize(UBound(a), 4) = a
    End With
    koniec = Timer
    MsgBox Format(koniec - start, "0.00")
End Sub

0,22 sek.
------------------------------------------------------

Średnia z 20 prób na antyku:
AMD Athlon 64 3000+ Venice 90nm
1,00 GB 1-Kanałowy DDR @ 167MHz

mancia14: 2,28 sek.
umiejead: 1,66 sek.
kuma: 0,33 sek.
Tajan: 0,31 sek.
Tajan2: 0,18 sek.
kuma2: 0,22 sek.

The winner is: Tajan2 :clap

:off Pytanie: dlaczego nie mogę wstawić więcej niż 4 cytaty/kody? Ograniczenie phpBB?
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
Ostatnio zmieniony przez umiejead 08-01-2019, 21:05, w całości zmieniany 4 razy  
ID posta: 360002 Skopiuj do schowka
 
 
Tajan


Pomógł: 4351 razy
Posty: 9667
Wysłany: 08-01-2019, 19:38   

Aby było sprawiedliwie, to w moim makrze przed
Kod:
For i = 1 To UBound(kolArr)
należałoby dodać:
Kod:
Sheets("Arkusz1").UsedRange.ClearContents
bo makro kumy traci na tym zapewne nieco milisekund :-)

PS. Bez problemu dodałem znaczniki kodu do twojego postu :-)
ID posta: 360009 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 335 razy
Posty: 1785

Wysłany: 08-01-2019, 20:05   

Cytat:
Bez problemu dodałem znaczniki kodu do twojego postu
? No to gdzie jest kod Tajan2? Chyba że tylko u mnie tak się dzieje :?
.

1.png
Plik ściągnięto 13 raz(y) 78.75 KB

_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 360012 Skopiuj do schowka
 
 
Tajan


Pomógł: 4351 razy
Posty: 9667
Wysłany: 08-01-2019, 20:20   

Chyba masz problem z przeglądarką. U mnie jest OK.

ekran.png
Plik ściągnięto 9 raz(y) 30.12 KB

ID posta: 360013 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 335 razy
Posty: 1785

Wysłany: 08-01-2019, 20:55   

Faktycznie: na Chrome jest OK. Nie wiem OCB. W wolnej chwili sprawdzę.

PS. Nikt wcześniej nie miał podobnego problemu?
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 360018 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe