- Netfone
- Okosóra és okoskiegészítő topik
- Vivo X200 Pro - a kétszázát!
- Garmin Fenix 7 és 7S - profi sport megszokásból
- Yettel topik
- T Phone 2 Pro - majdnem mindenben jobb
- One mobilszolgáltatások
- Megérkezett a Google Pixel 7 és 7 Pro
- Hatalmas kedvezménnyel nyit az Ulefone új csúcsmodellje
- Motorola Moto G84 - színes egyéniség
Hirdetés
-
Mobilarena
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
Mutt
senior tag
válasz
T.Lacci #19775 üzenetére
Hello,
A makrót fel tudod gyorsítani a következőkkel:
1. képérnyőfrissítés kikapcsolása (ScreenUpdating)
2. események letiltása (EnableEvents)
3. objektumok létrehozása (Set parancs)
4. változók definiálása konkrét típussal (Variant mellőzése)
5. beépített függvények használata (pl. Sum egy saját összegzés helyett)
6. üres cellák ignorálásaEgy 100 ezer darabos halmazon futtattam a különböző variációkat az eredmények:
Könnyedén gyorsítható tehát az első 2 opcióval.
Sub Szorzas()
Dim tartomany As Range, cella As Range, szorzo As Double
Set tartomany = Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each cella In tartomany
'Feltételek megdása
Select Case cella.Value
Case 1 To 10000
szorzo = 1.4
Case 10001 To 20000
szorzo = 1.3
Case 20001 To 30000
szorzo = 1.2
Case Else
szorzo = 0.9
End Select
'Szorzat beírása az E oszlopba
Cells(cella.Row, "E") = cella.Value * szorzo
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End SubA függvényest pedig a 19740-es hozzászólásban találod.
üdv
-
Delila_1
veterán
-
-
Mutt
senior tag
válasz
T.Lacci #19737 üzenetére
Hello,
Különben az miért van hogy nem teljesen pontosan számol? (1000 x 1,4 = 1,399999999)
A kapott makróban a szorzo változót Single típusról Double típusra állítsd át.
...a táblázatomnak szöveges fejléce van...
A For sor = 1 To usor részben az 1-est írd át 2-re (vagy arra a sorra ahonnan a számok kezdődnek).
Az eredeti feladat nem követel makrót, akár egy FKERES segítségével is megoldható.
pl. E1-be: =D1*FKERES(D1;{0\1,4;10001\1,3;20001\1,2;30001\1,1};2)Itt a kapcsos zárójelekben van a keresési tartomány, 0 és 10000 között 1,4-et talál meg, 10001 felett 1,3-at és így tovább,
Ha mégis makró kell, akkor itt van egy gyorsabb:
Sub Szorzas2()
Dim rng As Range
'kiválasztjuk a csak számokat tartalmazó cellákat a D-oszlopban
Set rng = Columns("D").SpecialCells(xlCellTypeConstants, xlNumbers)
'jobbra tőlük számoljuk az új értéket; fkeres hasonló mint fent de a vba miatt máshogy kell megadni
rng.Offset(, 1).FormulaR1C1 = "=RC[-1]*VLOOKUP(RC[-1],{0,1.4;10001,1.3;20001,1.2;30001,1.1},2)"
'értékeket bemásoljuk
Columns("E").Copy
Columns("E").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End Subüdv
-
Delila_1
veterán
válasz
T.Lacci #19707 üzenetére
Sub Szorzas()
Dim sor As Long, usor As Long, szorzo As Single
'Alsó sor meghatározása a D oszlopban)
usor = Range("D" & Rows.Count).End(xlUp).Row
'Ciklus az elsőtől az utolsó sorig
For sor = 1 To usor
'Feltételek megdása
Select Case Cells(sor, "D")
Case 1 To 10000
szorzo = 1.4
Case 10001 To 20000
szorzo = 1.3
Case 20001 To 30000
szorzo = 1.2
Case Else
szorzo = 0.9
End Select
'Szorzat beírása az E oszlopba
Cells(sor, "E") = Cells(sor, "D") * szorzo
'Ha kerekítve akarod megadni a szorzatot, a fenti helyett
'a lenti sort alkalmazd a szorzásra
'Cells(sor, "E") = Round(Cells(sor, "D") * szorzo, 0)
Next
End SubA Case sorokat folytathatod. A Case Else sorhoz azt az utasítást add, ami azokra az összegekre vonatkozik, amikhez a fölötte lévő feltételekben nem határoztál meg szorzót. Ki is hagyható.
Figyelj, hogy a szorzók tizedes ponttal, nem veszővel írandók a makróban! -
Delila_1
veterán
válasz
T.Lacci #19601 üzenetére
ter.Replace What:="Gipszkarton", Replacement:="25-0-0-0", lookat:=xlWhole
ter.Replace What:="Gipszkarton tartozékok", Replacement:="120-0-0-0", lookat:=xlWholeHa a végéről lemarad a , lookat:=xlWhole, akkor csinálja azt, amit írtál, mert alapból az xlpart opciót hajtja végre.
Az xlpart rész szöveget cserél, xlwhole teljes cellát.
Új hozzászólás Aktív témák
Hirdetés
- Bitdefender Total Security 3év/3eszköz! - Tökéletes védelem, Most kedvező áron!
- Adobe Előfizetések - Adobe Creative Cloud All Apps - 12 Hónap
- PC Game Pass előfizetés
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Kaspersky, BitDefender, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Telefon felvásárlás!! iPhone 11/iPhone 11 Pro/iPhone 11 Pro Max
- Samsung Galaxy Tab A9+ 5G 128GB, Kártyafüggetlen, 1 Év Garanciával
- BLUESUMMERS NVMe SSD adapter
- REFURBISHED és ÚJ - HP USB-C Dock G5 docking station (5TW10AA) - 3x4K felbontás, 144Hz képfrissítés
- GYÖNYÖRŰ iPhone 13 mini 128GB Blue -1 ÉV GARANCIA - Kártyafüggetlen, MS3045, 96% Akkumulátor
Állásajánlatok
Cég: FOTC
Város: Budapest