MS Excel

Dobrý den,
V práci zápasím s makrem, které pracuje se dvěma soubory s velkým množstvím materiálů (cca 65k). Jeden dokument (wbJG) má nahrané ceny s jednotkami, které je potřeba mezi sebou vydělit a poté vynásobit 100. Druhý dokument (wbVer1) shromažďuje potřebné data k materiálům a v tomto případě ke každému materiálu přidá cenu, která se vypočítala v předešlém dokumentu. Avšak tento dokument se aktualizuje každý měsíc a je potřeba, aby se nové ceny porovnávali s již uvedenými. Sestavil jsem makro, které splňuje to, co potřebuji, ale pouze na pár materiálech. Když jsem to chtěl udělat na všech materiálech, tak to jelo cca 3h a bez výsledky. Vypnul jsem to. Kód makra níže:
Sub updateCeny()
Dim wbVer1 As Workbook
Dim wbJG As Workbook
Dim wsVer1 As Worksheet
Dim wsJG As Worksheet
Dim lastRowVer1 As Long
Dim lastRowJG As Long
Dim i As Long
Dim j As Long
Dim materialExists As Boolean

Application.ScreenUpdating = False

Set wbVer1 = Workbooks.Open("cesta")
Set wbJG = Workbooks.Open("cesta")

Set wsVer1 = wbVer1.Sheets("List1")
Set wsJG = wbJG.Sheets("List1")

lastRowVer1 = wsVer1.Cells(wsVer1.Rows.Count, "A").End(xlUp).Row
lastRowJG = wsJG.Cells(wsJG.Rows.Count, "A").End(xlUp).Row

For i = 3 To lastRowJG
wsJG.Cells(i, "G").Value = Replace(wsJG.Cells(i, "G").Value, "EUR", "")
wsJG.Cells(i, "G").Value = Replace(wsJG.Cells(i, "G").Value, ".", "")
wsJG.Cells(i, "H").Value = Replace(wsJG.Cells(i, "H").Value, ".", "")
Next i

For i = 3 To lastRowJG
Dim material As String
Dim price As Double
Dim euroPrice As String
Dim exchangeRate As String

material = wsJG.Cells(i, 1).Value
euroPrice = wsJG.Cells(i, 7).Value
exchangeRate = wsJG.Cells(i, 8).Value

euroPrice = Replace(euroPrice, "EUR", "")
euroPrice = Replace(euroPrice, ".", "")
price = CDbl(euroPrice)

exchangeRate = Replace(exchangeRate, ".", "")

Dim calculatedPrice As Double
If IsNumeric(exchangeRate) And CDbl(exchangeRate) <> 0 Then
calculatedPrice = price / CDbl(exchangeRate) * 100
Else
calculatedPrice = 0
End If

materialExists = False
For j = 2 To lastRowVer1
If wsVer1.Cells(j, 1).Value = material Then
materialExists = True
Dim existingPrice As Variant
existingPrice = wsVer1.Cells(j, 10).Value
Dim cellColor As Long
cellColor = wsVer1.Cells(j, 10).Interior.Color

Select Case True
Case existingPrice = "AT mat"
If calculatedPrice <> 0 Then

End If
Case IsNumeric(existingPrice)
Dim existingPriceValue As Double
existingPriceValue = CDbl(existingPrice)

If calculatedPrice = existingPriceValue Then
ElseIf calculatedPrice <> 0 And existingPriceValue <> 0 Then
wsVer1.Cells(j, 10).Value = calculatedPrice
wsVer1.Cells(j, 10).Interior.Color = RGB(255, 0, 0)
ElseIf calculatedPrice = 0 And existingPriceValue <> 0 Then
wsVer1.Cells(j, 10).Value = existingPrice & "*"
wsVer1.Cells(j, 10).Interior.Color = RGB(255, 0, 0)
ElseIf existingPriceValue = 0 Or existingPrice = "no info" Or InStr(existingPrice, "*") And calculatedPrice <> 0 Then
wsVer1.Cells(j, 10).Value = calculatedPrice
wsVer1.Cells(j, 10).Interior.Color = RGB(255, 0, 0)
End If
Case existingPrice = "no info", InStr(existingPrice, "*") > 0
If calculatedPrice <> 0 Then
wsVer1.Cells(j, 10).Value = calculatedPrice
wsVer1.Cells(j, 10).Interior.Color = RGB(255, 0, 0)
End If
Case existingPrice = 0
If calculatedPrice = 0 Then
End If
End Select

If wsVer1.Cells(j, 10).Interior.Color = cellColor And calculatedPrice = existingPriceValue Then
wsVer1.Cells(j, 10).Interior.ColorIndex = xlNone
End If
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub

Zaslat odpověď >

Milan-158(14.12.2023 11:13)#055798

Ahoj, pošli oba soubory s několika daty.
Nejdřív to bude chtít vyladit aby to dělalo co to má.
Máš tam např. proměnnou materialExists, ale vůbec s ní nepracuješ. Zřejmě to mělo sloužit na opuštění cyklu pomocí Exit For, ale to tam taky nevidím. Takže počet smyček bude vždy maximální (lastRowJG * lastRowVer1), což je často zbytečné...
V druhém kroku by se hodilo nahradit "Range operace" na operace v rámci array, které jsou násobně rychlejší. Tipuji, že po optimalizaci se dá dostat ze 3 hodin na desetinu...citovat

Jen1984(14.12.2023 13:06)#055801

Dokumenty jsem ořezal, ale makro funguje, tak jak by mělo. Jde i o to, že každý měsíc tam přibývají nové a nové materiály. Ale věřím, že tam je hodně možností, jak toto makro urychlit. Děkuji za jakoukoliv pomoc.

Příloha: xlsx

55801_wb.xlsx (38kB, staženo 5x)

citovat

Jen1984(14.12.2023 13:07)#055802

Druhý dokument.

Příloha: xlsx

55802_ver1.xlsx (13kB, staženo 4x)

citovat

elninoslov(14.12.2023 13:16)#055803

Presne ako vraví Milan. To treba celé prerobiť. Zapísať 10000 zbytočných buniek v poli (to isté na svoje miesto) je určite rýchlejšie ako 1000 buniek po jednej. Sú tam zbytočné podmienky (alebo makro nie je celé). Duplicitné operácie
wsJG.Cells(i, "G").Value = Replace(wsJG.Cells(i, "G").Value, "EUR", "")
robí predsa to isté s tou istou hodnotou ako toto
euroPrice = Replace(euroPrice, "EUR", "")
Vyfarbenie nerobiť po jednom, ale chystať si spoločnú Range a vyfarbiť naraz.
Prestupovanie medzi Excelom a makrom je pomalé, a preto neustále
wsVer1.Cells(j, 10)
spomaľuje
...

Prílohy, kde bude pár dát, s rovnakým usporiadaním, vzorcami, formátmi a pod, ako máte v reále. Anonymizované ale kde niečo je tak to tam nechajte len zmeňte. Nemažte napr. hlavičky.

Uvidíme...citovat

Jen1984(14.12.2023 15:00)#055805

elninoslov
Když vymažu jednu z duplicit, tak to pak neplní funkce, které to má mít. Když ponechám první definici, tak se z dokumentu WB neodstraňuje měna a tečky. Pokud Ponechám druhou definici, tak se ke všem cenám připisuje *, což je špatně.citovat

elninoslov(14.12.2023 15:22)#055806

Prvý nástrel len prasácky poupravované (zdôrazňujem prasácky) a povynechávané. Snáď to robí čo má. Niektoré tie podmienky som vôbec nepobral, tak som ich ponechal. Všetko, čo sa dalo, je cez polia.
Vyskúšajte.

Viac nemám čas. Všetci zdúchli, a tak idem nachystať na tajnáša nejaké Vianočné veci. Ale psst, nie že to tu rozkecáte ...

Ak to bude funkčné, tak to poupravujem, aj nejaký popis dodám.
PS: Inak prílohy ste dal presne také ako som nechcel. Nie je vidno, či niekde nie sú vzorce. Dalo by sa pre zjednodušenie preplácnuť všetky dáta (aj nemenené), bolo by menej polí...

EDIT:
Dnes som si to ráno vyskúšal, a Match je nedostatočný. Použijem Collection - mnohonásobne rýchlejšie hľadanie. Nachádzajú sa v prehľadávanom súbore duplicitné materiály?

EDIT2:
Tak sa snažím pochopiť tie Vaše podmienky... No, dobré by asi bolo, začať od začiatku, a to vysvetlením, čo to má robiť a za akých podmienok. Napr. ak dôjde k výpočtu (lebo je číslo a nie text) a zároveň pri výpočte dôjde k zmene očerveň, inak zachovaj pôvodnú farbu/ zmaž akúkoľvek farbu. Atď.
To makro je celé? K čomu potom toto?
Case existingPrice = 0
If calculatedPrice = 0 Then
End If
V tomto riadku
ElseIf existingPriceValue = 0 Or existingPrice = "no info" Or InStr(existingPrice, "*") And calculatedPrice <> 0 Then
sa zbytočne testuje
Or existingPrice = "no info"
lebo nikdy nenastane, pretože to je v bloku
Case IsNumeric(existingPrice)
Ďalej priložte takú prílohu, kde bude 1 riadok z každej eventuality, ktorá sa môže vyskytnúť, aj s jeho požadovaným výsledkom včetne farby (kedy ma červená vzniknúť, zaniknúť, ponechať).
text, číslo, farba, "*", "no info", "AT mat", ...
Desatinné čísla v stĺpci G neprevádzate na skutočné čísla. Ostávajú ako text. To sa má asi previesť, nie?

Příloha: zip

55806_zrychlit-makro.zip (66kB, staženo 7x)

citovat

elninoslov(15.12.2023 14:26)#055816

Urobil som verziu cez vyhľadávanie v Collection. 100000 vyhľadávaní v ďalších 100000 riadkoch spracuje aj výpisom priebehu, konverziou stringov na čísla za cca 6-7 sekúnd. Problémom je vyfarbovanie. A to je ohromný časový problém. Zakomponoval som zložité kontroly a čiastkové zafabovanie po častiach. Potom to ide celkom dobre. Keď privriem oči, tak čo % to sekunda. Dôrazne neodporúčam pri vygenerovaní 100000 riadkov (na to je tam makro, aby nebola veľká príloha) odpovedať NIE na otázku, či má vyfarbovať po krokoch. Ide to ako raketa. Obmedzujú to len farby...
Ešte poriadne pochopiť tie podmienky...

Příloha: zip

55816_zrychlit-makro.zip (74kB, staženo 5x)

citovat

Jen1984(15.12.2023 16:06)#055819

Mockrát děkuji. Omlouvám se za to, ale teprve se makra učím a je to pro mě stále složité pochopit a z toho důvodu to je přeplácané a upřímně si s tím nedokážu moc poradit.
Co se týká podmínek, tak jde o to, že dokument ver1 obsahuje finálové ceny a ty se mění každý měsíc. Ceny ve ver1 mají buď číselnou hodnotu, nebo číselnou hodnotu s hvězdičkou, nebo mají označení no info, nebo AT mat. Dokument wb slouží ke stahování cen ze SAP, kde je vždy uvedené buď částka nebo 0, nic víc. U podmínek dochází k tomu, aby se porovnávala nově vypočítaná cena z wb se stávající cenou z ver1.
Pokud jsou ceny stejné, tak ponechat cenu uvedenou.
Pokud je ve wb cena číslo (ne 0) a ve ver1 je jiná nebo AT mat, "no info", nebo cena s hvězdičkou, tak ji přepsat.
Pokud je ve wb 0 a ve ver1 cena číslo, tak přidat k této uvedené ceně hvězdičku.
Pokud je ve wb 0 a ve ver1 je "no info", "AT mat", cena s hvězdičkou, tak ponechat.
Pokud je ve wb 0 a ve ver není uvedená cena (protože je tam nový materiál), tak se přidá "no info".
Snad jsem na žádnou nezapomněl. Co se týká barevného zvýraznění, tak tam není určitě potřeba. Spíš přemýšlím, jak jinak mít přehled o tom, u kterých materiálů došlo ke změně.citovat

elninoslov(16.12.2023 0:18)#055834

Ak sa Vám zdalo Vaše makro preplácané, tak z môjho odpadnete.

Samotná výkonová časť (hľadanie) je triviálna, pár riadkov. Ale desaťnásobne to zväčšuje, zneprehľadňuje a znižuje čitateľnosť a prehľadnosť práve všetok potrebný balast, ako kontroly, výpis priebehu v StatusBare, čiastkové vyfarbovanie (aby Excel nehavaroval ak oblasť obsahuje príliš veľa podoblastí) a pod., messageboxy, 25 riadkov kódu len vytvára náhodných 100K dát, ...

Zajtra keď vyjde čas a aj trochu elánu, skúsim si Váš príspevok ešte párkrát prečítať, a uvidím či urobím nejaké zmeny.citovat

Téma: Úprava Makra

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje