-
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- Xbox Series X|S
- Facebook és Messenger
- OpenMediaVault
- Fejhallgató erősítő és DAC topik
- Először beszélt bővebben az új Xbox konzolról a Microsoft
- Milyen asztali (teljes vagy fél-) gépet vegyek?
- exHWSW - Értünk mindenhez IS
- iPhone topik
- AMD GPU-k jövője - amit tudni vélünk
- Kész rémálom lesz Linuxot használni jövőre az USA egyes államaiban
- További aktív témák...
- Vírusirtó, Antivirus, VPN kulcsok GARANCIÁVAL!
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Windows 10/11 Home/Pro , Office 2024 kulcsok
- Game Pass Ultimate előfizetések 1 - 36 hónapig azonnali kézbesítéssel a LEGOLCSÓBBAN! AKCIÓ!
- Bitdefender Total Security 3év/3eszköz! - Tökéletes védelem.
- Bomba ár! Dell Latitude 5495 - Ryzen 5 I 8-16GB I 256SSD I 14" FHD I HDMI I Radeon I Cam I W11 I Gar
- 0perces DDR5 5600 vadiúj Ramaxel 2x16GB memória 1 év garancia
- BESZÁMÍTÁS! Asus H110M i5 7500 8GB DDR4 250GB SSD GTX 1050Ti 4GB ZALMAN T3 Plus Deepcool 400W
- HIBÁTLAN iPhone 15 Pro 128GB Black Titanium-1 ÉV GARANCIA - Kártyafüggetlen, MS4660
- 165 - Lenovo Legion Pro 7 (16IRX9H) - Intel Core i9-14900HX, RTX 4080 (ELKELT)
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest