Hirdetés
- Xiaomi Mi 9T Pro - tizenegyes!
- iPhone topik
- Samsung Galaxy S25 Ultra - titán keret, acélos teljesítmény
- Nagy aksival és erős hardverrel megjött Magyarországra a Poco X8 Pro és Pro Max
- Poco F5 - pokolian jó ajánlat
- One mobilszolgáltatások
- VoLTE/VoWiFi
- Vivo X300 Ultra - tárcsázz, ha van rá keret!
- Xiaomi 14 - párátlanul jó lehetne
- Így spórolhat az Apple az iPhone 18 kijelzőin
-
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
- Ingatlanos topic!
- Ubuntu Linux
- Gyúrósok ide!
- Bluetooth hangszórók
- Egyre inkább szoftverrel segítene a Core CPU-k teljesítményén az Intel
- Energiaital topic
- AMD vs. INTEL vs. NVIDIA
- Autós topik
- Túllépne a DRAM limitjein a Neo Semiconductor-féle 3D X-DRAM
- HiFi műszaki szemmel - sztereó hangrendszerek
- További aktív témák...
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- HP. Laptop. i5. Model: 15-da1002nq
- MEGA AKCIÓ! - Jogtiszta Windows - Office & Autodesk & CorelDRAW - Azonnal - Számlával - Garanciával
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- HIBÁTLAN iPhone 15 Pro 128GB Natural Titanium -1 ÉV GARANCIA - Kártyafüggetlen, MS4671
- Jó ÁRON ELADÓ! Üzleti HP Elitebook 1040 G9 4g modem! / i5-1245U 16GB 256GB FHD+
- Lenovo ThinkStation P300 Workstation,i5-4590,16GB DDR3,256GB SSD,2GB VGA,WIN11
- ÁRGARANCIA!Épített KomPhone i9 14900KF 64GB RAM RTX 5090 32GB GAMER PC termékbeszámítással
- Samsung Galaxy S24 Ultra 12/256 GB Titanium Gray 6 hónap Garancia Beszámítás Házhozszállítás
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest


Fferi50
