-
Fototrend
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
-
-
#10803
m.zmrzlina
senior tag
djzomby
#10788
m.zmrzlina
senior tag
válasz
djzomby
#10788
üzenetére
Na tudtam, hogy egyszerűbben is lehet ezt.
Másold új modulba a következőt:
Function SZINESÖSSZEG(minta As Range, tartomany As Range)
Dim cella As Range, osszeg As Double
szin = minta.Font.Color
For Each cella In tartomany
If cella.Font.Color = szin Then
osszeg = osszeg + cella.Value
End If
Next cella
SZINESÖSSZEG = osszeg
End FunctionLegjobb ha a personal.xls (personal.xlsb) -be teszed mert akkor minden megnyitott munkafüzetben rendelkezésre fog állni egy SZINESÖSSZEG() nevű új függvény. Úgy használod mint a SZUM() fv-t csak ennek az első paramétere egy olyan abszolút cellahivatkozás (pl: $A$1) amiben ugyanolyan színű karakterek vannak mint amit össze akarsz adni.
Hogy érthetőbb legyen itt egy kép:
Köszönet az ötletért (ki másnak mint) Delila_1-nek
-
#10797
m.zmrzlina
senior tag
djzomby
#10788
m.zmrzlina
senior tag
válasz
djzomby
#10788
üzenetére
Ilyen kicsi és jól körülhatárolt tartományoknál talán még nem fájóan amatőr megoldás számlálós ciklusra bízni a dolgot:
Sub szinösszeg_v2()
Dim pirososszeg As Single, feketeosszeg As Single
Dim i As Integer, j As Integer, betuszine As Integer
Cells(1, 1).Select
For i = 1 To 10
pirososszeg = 0
feketeosszeg = 0
For j = 1 To 6
betuszine = ActiveCell.Font.ColorIndex
Select Case betuszine 'ha a szöveg színe piros
Case Is = 3 'pirososszeghez aktív cella értékét hozzáadja
pirososszeg = ActiveCell.Value + pirososszeg
Case Is = 1 ''ha a szöveg színe fekete
feketeosszeg = ActiveCell.Value + feketeosszeg 'feketeoszeghez aktív cella értékét hozzáadja
End Select
ActiveCell.Offset(0, 1).Select 'következő cella
Next j
With Range("H" & i) ' sor végére G oszlopba
.Font.ColorIndex = 3 'pirossal
.Value = pirososszeg 'pirososszeget kiír
End With
With Range("G" & i) ' sor végére H oszlopba
.Font.ColorIndex = 1 'feketével
.Value = feketeosszeg 'feketeosszeget kiír
End With
ActiveCell.Offset(1, -6).Select 'vissza a sor elejére
Next i
End SubHa a tartomány változó akkor kötelező, ha a mérete jelentősen megnő akkor érdemes újragondolni a koncepciót.
-
#10787
m.zmrzlina
senior tag
djzomby
#10786
m.zmrzlina
senior tag
válasz
djzomby
#10786
üzenetére
Van egy szörnyű gyanúm, hogy van erre egyszerűbb megoldás is de több időm erre csak este lesz. Ha addig nem kapsz valami egyszerűbb megoldást akkor használd ezt:
Sub szinosszeg()
Range("A1").Select
Dim pirososszeg As Integer, feketeosszeg As Integer
Dim betuszine As Integer
pirososszeg = 0
feketeosszeg = 0
Do Until ActiveCell.Value = ""
betuszine = ActiveCell.Font.ColorIndex
Select Case betuszine
Case Is = 3
pirososszeg = ActiveCell.Value + pirososszeg
Case Is = 1
feketeosszeg = ActiveCell.Value + feketeosszeg
End Select
ActiveCell.Offset(1, 0).Select
Loop
Range("H2").Value = pirososszeg
Range("G2").Value = feketeosszeg
End Sub -
#10765
m.zmrzlina
senior tag
djzomby
#10761
m.zmrzlina
senior tag
válasz
djzomby
#10761
üzenetére
Nem tudom honnantól kell elmagyarázni a dolgot (és milyen Excel verziót használsz) de ha jól értem több színű szöveged van és attól függően, hogy milyen színű a szöveged kell különböző dolgokat csinálnia az Excelnek.
Az alábbi makró azt csinálja, hogy I3-tól végigmegy addig amíg van valami az oszlopban és a cella mellé írja a cella szövegének színkódját.
VB-be beilleszteni Insert>Modul menüből lehet
Sub szovegszin()
Range("I3").Select
Dim betuszine As Integer
Do Until ActiveCell.Value = ""
betuszine = ActiveCell.Font.ColorIndex
Select Case betuszine
Case Is = 3 'itt adod meg a szín kódjával, hogy milyen színű szöveg esetén...
ActiveCell.Offset(0, 1).Value = "A szomszédos cella betűszín kódja:" & betuszine 'itt adod meg, hogy mi történjen
Case Is = 4
ActiveCell.Offset(0, 1).Value = "A szomszédos cella betűszín kódja:" & betuszine
Case Is = 5
ActiveCell.Offset(0, 1).Value = "A szomszédos cella betűszín kódja:" & betuszine
Case Is = 6
ActiveCell.Offset(0, 1).Value = "A szomszédos cella betűszín kódja:" & betuszine
Case Is = 7
ActiveCell.Offset(0, 1).Value = "A szomszédos cella betűszín kódja:" & betuszine
Case Is = 8
ActiveCell.Offset(0, 1).Value = "A szomszédos cella betűszín kódja:" & betuszine
End Select
ActiveCell.Offset(1, 0).Select
Loop
End SubA Case Is sorban adod meg hogy milyen szín esetén, a következő sorban pedig hogy mit csináljon a program.
Színekről bővebb információ itt.
Jó lenne több részletet tudni a feladatról mert így csak vaktában lövöldözünk.
Még véletlenül eltaláljuk egymást
![;]](http://cdn.rios.hu/dl/s/v1.gif)
Új hozzászólás Aktív témák
Fferi50- Chieftec-Prohardver nyereményjáték
- Samsung Galaxy Watch7 - kötelező kör
- PlayStation 5
- Luck Dragon: Alza kuponok – aktuális kedvezmények, tippek és tapasztalatok (külön igényre)
- Samsung kuponkunyeráló
- Kamionok, fuvarozás, logisztika topik
- Automata kávégépek
- Kertészet, mezőgazdaság topik
- exHWSW - Értünk mindenhez IS
- Linux kezdőknek
- További aktív témák...
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.
- PC Játékok
- Bitdefender Total Security 3év/3eszköz! - Tökéletes védelem.
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Dell Precision 7550,15.6,FHD,i7-10850H,16GB DDR4,256GB SSD,Quadro T2000 4GB VGA,WIN11,LTE
- Új Honor X7d 128GB, Kártyafüggetlen, 1 Év Garanciával
- Apple iPhone 16 Pro Max 256GB Black Titanium használt, szép állapot 96% akku (247 ciklus) 6 hó
- AZONNALI SZÁLLÍTÁS Eredeti Microsoft Office 2019 Professional Plus
- GYÖNYÖRŰ iPhone SE 2022 128GB Red -1 ÉV GARANCIA - Kártyafüggetlen, MS4535, 100% AKKSI
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest