-
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
-
Fferi50
Topikgazda
válasz
mr.nagy
#23660
üzenetére
Szia!
Elvileg két lehetőséged is van erre.
Az egyik, hogy amikor végigmész a sorokon, akkor megnézed, hogy az éppen látható-e:
cells(i,col).entirerow.hidden = true akkor a sor el van rejtve, ellenkező esetben látható. Nyilván a nem látható sorokat nem kell beszámolni a nyomtatásnál.A másik a specialcells metódussal kiválasztod a látható sorokat és azon mész végig, de itt vigyázni kell, mert nem lesz összefüggő a területed, tehát minden területet figyelembe kell venned:
set lathato=activesheet.usedrange.specialcells(xlcelltypevisible)
for each terulet in lathato.areas
for each sor in terulet.rows
'ide írod a kódot
next
nextNyilván az oldaltörési kritériumot figyelned kell.
Üdv.
-
Fferi50
Topikgazda
válasz
mr.nagy
#23018
üzenetére
Szia!
Ennek érdekében az adott munkalap change eseményéhez kell makrót írnod:
Private Sub Worksheet_Change(ByVal Target As Range)
application.enableevents=false
if target.column=4 then target.formula="=Clean(""" & target.value & """)"
application.enableevents=true
end subÜdv.
-
Delila_1
veterán
válasz
mr.nagy
#18723
üzenetére
Az első makrót a lapodhoz rendeld. Ez figyeli az A5 cella változását.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$5" Then Osszefuz
End SubMikor új adatot viszel be az A5-be, meghívja a modulba írt Osszefuz makrót, ami a B5 cellában összefűzi az azonos kódhoz tartozó adatokat.
Sub Osszefuz()
Dim kriterium, Rng As Range, usor As Long, CV As Object
Application.EnableEvents = False
Range("B5") = ""
kriterium = Range("A5")
Range("A4:D4").AutoFilter
Selection.AutoFilter Field:=3, Criteria1:=kriterium
usor = Range("D4").End(xlDown).Row
Set Rng = Range("D5:D" & usor).SpecialCells(xlCellTypeVisible)
For Each CV In Rng
Range("B5") = Range("B5") & " " & CV
Next
Application.EnableEvents = True
Selection.AutoFilter
End Sub -
Delila_1
veterán
válasz
mr.nagy
#17942
üzenetére
Minden megoldható.
Jelöld ki a nyomtatási területet a Munka1 lapon, utána mehet a makró.
Gondolom, nem lesz nagyobb darabszám, mint 10.Sub cimke_nyomtatas()
Dim sor As Long, usor As Long, csz As Variant, db As Integer
Dim i As Integer, WS As Worksheet, sor1 As Integer
Set WS = Worksheets("Munka1")
Sheets("Munka2").Select
usor = Range("A" & Rows.Count).End(xlUp).Row
sor1 = 13
For sor = 2 To usor
WS.Range("C:C,L:L").ClearContents
csz = Cells(sor, "A")
db = Cells(sor, "B")
For i = 1 To db
If i < 6 Then
WS.Range("C" & sor1) = csz
sor1 = sor1 + 10
Else
If sor1 > 53 Then sor1 = 13
WS.Range("L" & sor1) = csz
sor1 = sor1 + 10
End If
Next
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
sor1 = 13
Next
End Sub -
Caipi
tag
válasz
mr.nagy
#17587
üzenetére
Remélem ez a megoldása:
+HA(D2-G2=3;0;HA(D2-G2>0;HA(D2-G2>0;ÖSSZEFŰZ("Felesleg : ";D2-G2);0);HA(ÉS(D2-G2<=0;J2>0);"0";ÖSSZEFŰZ("Hiány: ";D2-G2))))
Ha 3 db a maradék, akkor 0-t ír ki és semmi mást nem vizsgál, ha más összeg akkor végignézi a leírt kritériumaid alapján.
Üdv,
Caipi -
Caipi
tag
-
Caipi
tag
válasz
mr.nagy
#17563
üzenetére
Úgy értelmeztem, hogy a 3 darabot mindig félre szeretnéd tenni vésztartaléknak, így a maradékból levonódik, végeredményként a maradék-3 érték jelenik meg.Így, ha már csak 3 db marad, nem lesz felhasználható mennyiséged.
Ezek szerint félreértettem. Tudsz egy kicsit segíteni, hogy pontosan megértsem mit szeretnél a 3 darabbal?
Pl: ha készlet-eladás=3 db, akkor már 0-t írjon ki, ha nagyobb, akkor készlet-eladás?Köszönöm
-
lappy
őstag
válasz
mr.nagy
#17565
üzenetére
Szia!
HA jól értelmezem ezt
"ha felesleg van (tehát az első deffiníció pozítiv számot ad) akkor is legalább 3 darab maradjon meg és csak az e fölötti mennyiség legyen az eredmény vagy nulla"
akkor legalább 3 darab kell hogy maradjon más esetben 0 eredményt kell neked?
ha nem így van akkor sok sok pl. -val (kép) mutasd be sokkal egyszerűbb megérteni mindenkinek
-
Mutt
senior tag
válasz
mr.nagy
#16335
üzenetére
Hello,
Delila_1 megoldása mellett én is csináltam egy lehetséges megoldást. Felraktam ide.
A logikát leírom amit használ. Két lépésben fut neki.
1. Első lépésben ugyanazt csinálom, mint Delila_1 vagyis az abszolút értékben azonos helyeken cseréket végzek.
2. A második lépésben pedig megnézem hogy hol van a legnagyobb hiány ás azt kezdem el feltölteni minél több helyről (mindig a legkisebb készlettel rendelkező raktárt használva, így a lehető legtöbb raktárt nullázom le).Használata egyszerű: állj rá arra a sorra amelyikkel számolni akarsz és kattints a gombra. Az eredmény lapra kerül a végső állapot és a mozgások a jobb oldali táblázatba.
üdv.
-
-
Delila_1
veterán
válasz
mr.nagy
#16312
üzenetére
A demo 6. sora az átmozgatás előtti értékeket tartalmazza? Mert akkor nem értem.
A 10-es üzletből mind a 9 db-ot átteszed a 19-esbe, ennek eredményeként mindkét üzlet nullás lesz. Később a 14-es üzletből újabb 9 db-ot teszel a 19-esbe. Az már csak hab a tortán, hogy a 14-esben 14 db-ból 8+9=17-et teszel át a 16-osba és 19-esbe.Hogy van ez?
-
Delila_1
veterán
válasz
mr.nagy
#16294
üzenetére
Feltételezem, hogy az első a címsorod, a másodiktól kezdve vannak folyamatosan az adataid.
A lenti makró azt csinálja, amit kértél, plusz az AK oszlopba folyamatosan beírja a címsorban lévő üzlet nevét, ahol a plusz értéket átírta egy másik üzletbe (és ezt lenullázta), valamint azt, hogy mennyi volt ebben az üzletben és ebben a sorban az eredeti érték. Az AL oszlopba azt az üzletet írja, ahova át lett téve a plusz, az eredeti negatív értékkel és sorszámmal együtt.Pl. az Üzlet1-ben volt 5, az Üzlet5-ben -3, mindez a táblázatod 4. sorában, az AK oszlopban
Üzelet1 4.sor_5 db, az AL-ben Üzlet5 4.sor_-3 db lesz.Sub javaslat()
Dim oszlop As Integer, sor As Integer, usor, O1 As Integer, sorFelír
usor = Cells(Rows.Count, "A").End(xlUp).Row
sorFelír = 2
Range("AK:AL") = ""
Range("AK1") = "Honnan–eredeti érték": Range("AL1") = "Hova–eredeti érték"
For sor = 2 To usor
For oszlop = 14 To 32
If Cells(sor, oszlop) > 0 Then
For O1 = oszlop + 1 To 33
If Cells(sor, O1) < 0 Then
Cells(sorFelír, "AK") = Cells(1, oszlop) & " " & sor & ".sor_" & Cells(sor, oszlop) & " db"
Cells(sorFelír, "AL") = Cells(1, O1) & " " & sor & ".sor_" & Cells(sor, O1) & " db"
Cells(sor, O1) = Cells(sor, O1) + Cells(sor, oszlop)
Cells(sor, oszlop) = 0
sorFelír = sorFelír + 1
Exit For
End If
Next
End If
Next
Next
End Sub -
#11885
Fire/SOUL/CD
félisten
mr.nagy
#11884
-
#11694
Fire/SOUL/CD
félisten
mr.nagy
#11693
válasz
mr.nagy
#11693
üzenetére
Akkor csak 1 javaslatom maradt, nevezetesen, hogy Te egyesítsd a dokumentumot (ekkor belekerülnek az adatok) és ezt a doksit küld el, így nem kell külön a körlevél adatbázisául szolgáló táblát is küldeni. Innentől az már csak egy mezei/általános dokumentum, ést azt már illene tudni kinyomtatni. Ennél egyszerűbben nem fogod tudni ezt kivitelezni...
-
#11691
Fire/SOUL/CD
félisten
mr.nagy
#11689
válasz
mr.nagy
#11689
üzenetére
"...egyébként már megcsináltam volna Excelben de ott meg a háttérkép nyomtatásra nem találtam megoldást."
Pedig van: [link] Az a trükk, hogy egy alakzatot szúrj be, majd ennek a kitöltésénél képet/anyagmintát adj meg és itt tudod állítani az átlátszóságot...![;]](//cdn.rios.hu/dl/s/v1.gif)
Oly
Igen, az tűnne logikusnak, csak azt nem lehet kinyomtatni, nyomtatásban/nyomtatási képen az a background nem jelenik meg...
-
#11688
Fire/SOUL/CD
félisten
mr.nagy
#11685
-
Delila_1
veterán
válasz
mr.nagy
#11565
üzenetére
Teszteld ezzel. Csak estefelé leszek gép közelében, addig biztosan kibuknak a hibák.
A makró első részében (a **-os sorig) az első lap 100. oszlopába teszek egy x-et ahhoz, hogy a második rész gyorsabb futású legyen. Ezt az oszlopot a végén törlöm. Ha foglalt a 100. oszlop (CV), a 100-at a replace funkcióval írd át egy üres oszlop számára. Négy helyen szerepel.Sub szamitas()
Dim WS1 As Worksheet, WS2 As Worksheet, sor%, usor1%, usor2%, lel
Set WS1 = Sheets("első")
Set WS2 = Sheets("második")
WS2.Select
usor1% = Range("G2").End(xlDown).Row
For sor% = 2 To usor1%
On Error GoTo Köv
lel = WS1.Range("E:E").Find(Cells(sor%, "E")).Row
Select Case WS1.Cells(lel, 1)
Case 380
Cells(sor%, 7) = WS1.Cells(lel, 7) + Cells(sor%, 7)
WS1.Cells(lel, 100) = "x"
Case 390
Cells(sor%, 7) = WS1.Cells(lel, 7) - Cells(sor%, 7)
WS1.Cells(lel, 100) = "x"
End Select
Köv:
Next
'***************************************************************************
WS1.Select
usor1% = Range("A2").End(xlDown).Row
For sor% = 2 To usor1%
If Cells(sor%, 1) = 380 And Cells(sor%, 100) <> "x" Then
usor2% = WS2.Range("E2").End(xlDown).Row + 1
Range(Cells(sor%, 2), Cells(sor%, 5)).Copy WS2.Cells(usor2%, 2)
Cells(sor%, 7).Copy WS2.Cells(usor2%, 7)
End If
Next
Columns(100) = ""
End Sub -
Delila_1
veterán
válasz
mr.nagy
#11552
üzenetére
Ez a makró megoldja, bár egyúttal megszünteti az ellenőrzés lehetőségét. Az eredeti értékeket tartalmazó G oszlopot el is rejthetted volna.
Sub szamitas()
Dim WS1 As Worksheet, WS2 As Worksheet, sor%, usor%, lel
Set WS1 = Sheets("első")
Set WS2 = Sheets("második")
WS2.Select
usor% = Range("G2").End(xlDown).Row
For sor% = 2 To usor%
lel = WS1.Range("E:E").Find(Cells(sor%, "E")).Row
If WS1.Cells(lel, 1) = 380 Then
Cells(sor%, 7) = WS1.Cells(lel, 7) + Cells(sor%, 7)
Else
Cells(sor%, 7) = WS1.Cells(lel, 7) - Cells(sor%, 7)
End If
Next
End Sub -
Delila_1
veterán
válasz
mr.nagy
#11550
üzenetére
Majd kiderül, jól értettem-e. Mindkét lapon a G oszlopbeli értéket kell összegezni, vagy a különbségüket kiszámolni? Kivonásnál melyik a kivonandó?
A képen az első lap G értékéből vontam ki a második G-jét, ill. összegeztem azokat.
A második lap H2 cellájának képlete:
=HA(INDIREKT("első!A"&HOL.VAN(E2;első!E:E;0))=380;INDIREKT("első!G"&HOL.VAN(E2;első!E:E;0))+G2;INDIREKT("első!G"&HOL.VAN(E2;első!E:E;0))-G2)
-
Delila_1
veterán
válasz
mr.nagy
#11312
üzenetére
Sub Négy()
Dim sor As Integer, usor As Integer, sor_1 As Integer
sor_1 = 1
usor = Range("A65536").End(xlUp).Row
For sor = 10 To usor
If sor_1 < 5 Then
Cells(sor_1, 1) = Cells(sor, 1)
sor_1 = sor_1 + 1
Else
sor_1 = 1
sor = sor - 1
MsgBox "Ide jön a nyomtatás"
'ide jön a nyomtatás
Range("A1:A4").ClearContents
End If
Next
End Sub -
Delila_1
veterán
válasz
mr.nagy
#11309
üzenetére
Sub Tizenhat()
Dim sor As Integer, usor As Integer, oszlop As Integer, sor_1 As Integer
oszlop = 1: sor_1 = 1
usor = Range("A65536").End(xlUp).Row
For sor = 10 To usor
If sor_1 < 5 Then
Cells(sor_1, oszlop) = Cells(sor, 1)
sor_1 = sor_1 + 1
Else
sor_1 = 1
oszlop = oszlop + 4
sor = sor - 1
End If
If oszlop = 17 Then
MsgBox "Ide jön a nyomtatás"
'ide jön a nyomtatás
Range("A1:A4,E1:E4,I1:I4,M1:M4").ClearContents
oszlop = 1
End If
Next
End Sub -
Delila_1
veterán
válasz
mr.nagy
#11298
üzenetére
Az adat laphoz rendeld a makrót.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$G$5" Then
Dim meret As Integer
Select Case Len(Range("A6"))
Case Is <= 40
meret = 18
Case 41 To 100
meret = 16
Case 101 To 200
meret = 14
Case Is > 200
meret = 12
End Select
Range("A6").Font.Size = meret
End If
End Sub -
-
Delila_1
veterán
válasz
mr.nagy
#11296
üzenetére
Le kellene pontosan írnod. Milyen nevű lapon, melyik cellában van az fkeres keresési értéke, mert ettől változik a szöveged hossza.
Írd meg a lap nevét, és a tartományt, ahol keres az Fkeres.
Milyen nevű lapon van az A6:D6 összevont cellád?Szerk.: legjobb, ha beteszel egy képet a két lapról úgy, hogy a lapneveket is lehessen látni.
-
Delila_1
veterán
válasz
mr.nagy
#11294
üzenetére
A
Select Case Len(Target.Value)sor helyett
Select Case Len(cells(Target.row,5).Value)legyen. Az 5 az E oszlop, ahelyett annak az oszlopnak a számát írd be, ahol a hosszú szövegek megjelennek.
A Case kezdetű sorokban a Range(Target.Address).Font.Size helyére cells(target.row,5) kerüljön.
A
Set ter = Intersect(Target, Range("A6:D6"))
sorban az a terület legyen, ami előidézi a szövegek változását.Tehát ha az A6:D6 tartományt változtatod, és ennek hatására az E oszlopban változik a szöveg, akkor működik a most mutatott új sorral.
-
Delila_1
veterán
válasz
mr.nagy
#11292
üzenetére
A laphoz rendeld az alábbi makrót:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ter As Range
Set ter = Intersect(Target, Range("A6:D6"))
If ter Is Nothing Then
Select Case Len(Target.Value)
Case Is <= 40
Range(Target.Address).Font.Size = 18
Case 41 To 100
Range(Target.Address).Font.Size = 16
Case 101 To 200
Range(Target.Address).Font.Size = 14
Case Is > 200
Range(Target.Address).Font.Size = 12
End Select
Else: Exit Sub
End If
End Sub -
Delila_1
veterán
válasz
mr.nagy
#11278
üzenetére
Így gondoltad?
Sub Tizenhat()
Dim sor As Integer, usor As Integer, oszlop As Integer, sor_1 As Integer
oszlop = 3: sor_1 = 2
usor = Range("B65536").End(xlUp).Row
For sor = 13 To usor
If sor_1 < 6 Then
Cells(sor_1, oszlop) = Cells(sor, 2)
sor_1 = sor_1 + 1
Else
sor_1 = 2
oszlop = oszlop + 4
sor = sor - 1
End If
If oszlop = 19 Then
MsgBox "Ide jön a nyomtatás"
'ide jön a nyomtatás
Range("C2:R5").ClearContents
oszlop = 3
End If
Next
End Sub -
-
Delila_1
veterán
válasz
mr.nagy
#10984
üzenetére
Most látom, hogy még délelőtt hozzáírtál.
Az 5. sor a címsor? Ha igen, nem kell módosítanod a kódon, ha az már adatsor, akkor a For kezdetű sorban a 6-ot írd át 5-re.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim usor%, sor%
usor% = Range("A65536").End(xlUp).Row
If Not Intersect(Range("A1"), Target) Is Nothing Then
If Target = "" Then
Rows("5:50000").Hidden = False
Else
For sor% = 6 To usor%
If Cells(sor%, 1) <> Cells(1) Then Rows(sor%).Hidden = True
Next
End If
End If
End SubAz A1 cellába történő beíráskor elrejti azokat a sorokat, amik nem egyenlőek annak a tartalmával. A cella törlésekor minden sort felfed.
Abban az esetben, mikor az oszlopban nem található adatot írsz az A1-be, minden sort elrejt, de ekkor is láthatóvá teheted újra a sorokat az A1 tartalmának a törlésével. -
Delila_1
veterán
válasz
mr.nagy
#10982
üzenetére
Igen, megoldható. A laphoz kell rendelned a kódot.
Private Sub Worksheet_Change(ByVal Target As Range)
Range("A5").Select
If Intersect(Range("A1"), Target) = "" Then Exit Sub
If Not Intersect(Range("A1"), Target) Is Nothing Then _
Selection.AutoFilter Field:=1, Criteria1:=Range("A1")
End Sub -
#10585
Fire/SOUL/CD
félisten
mr.nagy
#10583
válasz
mr.nagy
#10583
üzenetére
Munkalapot alapban nem tud menteni az Excel, ha mentesz, akkor a munkafüzetet mented, ami meg a munkalapok összessége. Makróval az kivitelezhető, hogy egy adott munkalapon bekövetkezett változásokat kimentsen, de akkor gondoskodni kell arról is, hogy azt a legközelebb, a munkafüzet újbóli megnyitásakor be is töltse/módosítsa...
-
mr.nagy
tag
válasz
mr.nagy
#9302
üzenetére
Közben találtam egy megfelelő kódot, közzé teszem hátha másnak is jó lesz:
Sub Insert_Pic()
Dim URL As String
URL = Worksheets("Munka2").Range("A1").Value
Range("A5").Select
ActiveSheet.Pictures.Insert(URL).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 140
Selection.ShapeRange.Width = 200
Selection.ShapeRange.Rotation = 0#
End SubMinden esetre köszönöm Fire a segítséged!
-
#9301
Fire/SOUL/CD
félisten
mr.nagy
#9300
-
#9298
Fire/SOUL/CD
félisten
mr.nagy
#9297
válasz
mr.nagy
#9297
üzenetére
Itt egy egyszerű kód, ami az A1 "cellába" beilleszt bármilyen képet, 40x40 pixel méretben
Sub Insert_Pic()
Application.ScreenUpdating = False
SelectedPic = Application.GetOpenFilename _
("Képformátumok (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Jelöljön ki egy képet")
If SelectedPic <> False Then
Range("A1").Select
With ActiveSheet
.Pictures.Insert (MyPicture)
.Shapes(.Shapes.Count).Select
End With
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Top = ActiveCell.Top
.ShapeRange.Left = ActiveCell.Left
.ShapeRange.Height = 40
.ShapeRange.Width = 40
End With
End If
Application.ScreenUpdating = True
End SubNem láttam a teljes kódod, de feltételezem ez a sor hiányzik belőle (ami a fenti kódban is megtalálható)
.ShapeRange.LockAspectRatio = msoFalseHa ennek az értéke msoTrue, akkor mindegy milyen értéket adsz meg a Width/Height esetén, az eredeti méretben fog bekerülni a kép.
-
#9296
Fire/SOUL/CD
félisten
mr.nagy
#9295
-
#9294
Fire/SOUL/CD
félisten
mr.nagy
#9289
-
Delila_1
veterán
-
#8068
Fire/SOUL/CD
félisten
mr.nagy
#8067
válasz
mr.nagy
#8067
üzenetére
Hali!
Igen, a problémát az okozza, hogy a feltételes formázásnál, nem a hagyományos háttérszín módosítás megy végbe. Én egy teljesen más megközelítést használtam ebben a kódban, azaz én magam írom meg a feltételeket és színezem a cellákat a feltételnek megfelelően. Ez biztosan kifogástalanul működik.
A makróban 2 dolgot kell megadni(bele is írtam hogy hol), az egyik a tartomány, amiben a kód dolgozik, a másik az eredménytábla bal felső cellája(mert hogy eredménytáblát hoz létre, amit persze módosíthatsz az igényednek megfelelően)
Ahány feltétel, annyival kell módosítani illetve az eredménytábla kiírását bővíteni/csökkenteniPrivate Sub Worksheet_Change(ByVal Target As Range)
Dim My_Range As Range
'Itt megadod, hogy milyen tartományban dolgozzon a kód
Set My_Range = Range("C9:M9")
Dim My_Dest_Range As Range
'Itt megadod a kezdőcellát, ahova az eredménytábla kerül
Set My_Dest_Range = Range("C11")
If Not Intersect(My_Range, Range(Target.Address)) Is Nothing Then
Call My_Conditions(My_Range, My_Dest_Range)
End If
End SubEz pedig Module1-ba kerül
Sub My_Conditions(My_Range As Range, Dest_Range As Range)
Col1Index = 3
Col2Index = 4
Col3Index = 5
ColEmpty = xlNone
Col1Num = 0
Col1Sum = 0
Col2Num = 0
Col2Sum = 0
Col3Num = 0
Col3Sum = 0
ColEmptyNum = 0
ColEmptySum = 0
Application.ScreenUpdating = False
For Each CurrCell In My_Range
If CurrCell.Value >= 0 And CurrCell.Value <= 5 Then
CurrCell.Interior.ColorIndex = Col1Index
Col1Num = Col1Num + 1
Col1Sum = Col1Sum + CurrCell.Value
ElseIf CurrCell.Value > 5 And CurrCell.Value <= 7 Then
CurrCell.Interior.ColorIndex = Col2Index
Col2Num = Col2Num + 1
Col2Sum = Col2Sum + CurrCell.Value
ElseIf CurrCell.Value > 7 And CurrCell.Value <= 10 Then
CurrCell.Interior.ColorIndex = Col3Index
Col3Num = Col3Num + 1
Col3Sum = Col3Sum + CurrCell.Value
Else: CurrCell.Interior.ColorIndex = xlNone
ColEmptyNum = ColEmptyNum + 1
ColEmptySum = ColEmptySum + CurrCell.Value
End If
Next CurrCell
Dest_Range.Select
ActiveCell(1, 1) = "Piros cella darabszám"
ActiveCell(1, 2) = Col1Num
ActiveCell(2, 1) = "Piros cella összeg"
ActiveCell(2, 2) = Col1Sum
ActiveCell(3, 1) = "Zöld cella darabszám"
ActiveCell(3, 2) = Col2Num
ActiveCell(4, 1) = "Zöld cella összeg"
ActiveCell(4, 2) = Col2Sum
ActiveCell(5, 1) = "Kék cella darabszám"
ActiveCell(5, 2) = Col3Num
ActiveCell(6, 1) = "Kék cella összeg"
ActiveCell(6, 2) = Col3Sum
ActiveCell(7, 1) = "Színtelen cella darabszám"
ActiveCell(7, 2) = ColEmptyNum
ActiveCell(8, 1) = "Színtelen cella összeg"
ActiveCell(8, 2) = ColEmptySum
Application.ScreenUpdating = True
End SubFire.
-
Delila_1
veterán
válasz
mr.nagy
#8063
üzenetére
Fel akartam tölteni a módosított füzetet, de valahogy nem jött össze.
A képletek:
O9 =ÁTLAG(C9:M9)
Q9 =DARABTELI(C9:M9;">" & O9+2)
R9 =SZUMHA(C9:M9;">" & O9+2;C9:M9)
S9 =DARABTELI(C9:M9;"<" & O9-1)
T9 =SZUMHA(C9:M9;"<" & O9-1;C9:M9)
U9 =DARAB(C9:M9)-Q9-S9
V9 =SZUM(C9:M9)-R9-T9 -
ulrik19
tag
válasz
mr.nagy
#8063
üzenetére
Az interior.colorindex a cella beállított háttérszínét tartalmazza, a feltételes formázás hatására létrejött színt nem. (tehát a cella alapbeállítása van itt)
Sajnos nem tudok olyan egyszerű megoldásról, amivel meg lehet kapni az aktuális színt (tehát nincs a celláknak ilyen tulajdonságuk), persze kerülő úton meg lehet oldani:
a) ha azonos a feltételes formázás minden cellában, akkor nem szín, hanem maga a feltétel alapján összegzed, számolod össze a cellákat, tehát a feltételt "bedrótozod" a makróba
b) általánosabb megoldás, ha visszafejted a feltétel formázás paramétereit a cella FormatConditions alapján, és összeveted a cella aktuális értékével. Itt ahány feltételt állítottál be, annyi dimenziós tömböt látsz (FormatConditions(i), vagy FormatConditions.Item(i), ahol az elemek számát a FormatConditions.Count-ból kapod meg). Ha valamelyik feltétel teljesül, a feltétel háttérszíne lesz a megjelenő szín, FormatConditions(1).Interior.Colorindex, ha egyik sem, akkor a cella alapbeállítása szerinti szín látszik.ez talán lehet kiinduló alap hozzá:
[link] -
#8057
Fire/SOUL/CD
félisten
mr.nagy
#8056
válasz
mr.nagy
#8056
üzenetére
Hali!
Ez a kód remek alapot kínál a megoldásra, hisz nem kell mást tenned, mint a SumColor függvényt meghívni párszor. Pl A1 : A100 ban vannak az adatok, a feltételes formázás 3 színnel dolgozik, akkor erre a három színre kifested a B1/B2/B3 cellákat, majd valamelyik cellába pl C1-be meg beírod ezt
=SumColor(B1;A1:A100)+SumColor(B2;A1:A100)+SumColor(B3;A1:A100)Fire.
UI: Nem próbáltam ki, de elméletben így működnie kell a dolognak.
-
mr.nagy
tag
válasz
mr.nagy
#6851
üzenetére
Időközben magam is törtem a felyem és egy ilyen kódot csináltam:
Private Sub CommandButton1_Click()
Sheets("tábla").Activate
On Error Resume Next
ActiveSheet.Shapes("kép").Select
Selection.Delete
On Error GoTo 0
Dim myPic As Object
Set myPic = Sheets("tábla").Pictures.Insert(Sheets("adatok").Range("C1"))
myPic.Left = Sheets("tábla").Range("C5").Left + ((Sheets("tábla").Range("C5").Width - myPic.Width) / 2)
myPic.Top = Sheets("tábla").Range("C5").Top + ((Sheets("tábla").Range("C5").Height - myPic.Height) / 2)
myPic.Name = ("kép")
End SubEddig úgy tűnik, hogy működik, de ha van jobb özlet nyitott vagyok rá és megköszönöm!
-
#6765
Fire/SOUL/CD
félisten
mr.nagy
#6764
válasz
mr.nagy
#6764
üzenetére
Hali!
Majdnem...
Függőleges igazításnál a cella ill. kép magasságával kell számolni, ami mindkét esetben a Height nem pedig a Width.Persze ha a kép szélessége és magassága azonos, akkor nem jön ki a hiba.
(meg akkor sem, ha a cella magassága(sormagasság) kisebb, mint a kép magassága)Fire.
-
#6763
Fire/SOUL/CD
félisten
mr.nagy
#6762
válasz
mr.nagy
#6762
üzenetére
Hali!
Private Sub CommandButton1_Click()
Dim myPic As Object
Set myPic = ActiveSheet.Pictures.Insert(Range("A1"))
myPic.Left = ActiveSheet.Range("F1").Left + ((ActiveSheet.Range("F1").Width - myPic.Width) / 2)
myPic.Top = ActiveSheet.Range("F1").Top
MsgBox (ActiveSheet.Range("F1").Width)
End SubEbből adódóan házi feladat, hogy hogy lehet függőlegesen is középre igazítani.
(A példa alapján nem jelenthet gondot)Fire.
-
#6761
Fire/SOUL/CD
félisten
mr.nagy
#6760
-
#6757
Fire/SOUL/CD
félisten
mr.nagy
#6756
válasz
mr.nagy
#6756
üzenetére
Hali!
Ez az elv, ha egy adott cellában lévő linkre hivatkozol, akkor alakíts a makrón(nem nehéz). Ebben a példában azt tanulhatod meg, hogy hogy kell netről megnyitni egy (ebben az esetben) képet és azt hogy kell pozicionálni(itt A1 cellához van igazítva)
Private Sub CommandButton1_Click()
Dim myPic As Object
Set myPic = ActiveSheet.Pictures.Insert("http://www.prohardver.hu/dl/faces/c14.gif")
myPic.Left = ActiveSheet.Range("A1").Left
myPic.Top = ActiveSheet.Range("A1").Top
End SubFire.
-
ulrik19
tag
válasz
mr.nagy
#6453
üzenetére
szöveges mezővel (szerintem) nem fog működni.
ellenben ha dátumot teszel be (mondjuk mindig az akció kezdetét), akkor pl. minimum-ot hozzárendelve, ott lesz a keresett érték.de csinálhatod azt is, hogy külön-szeded a dátum1/dátum2 formátumot két oszlopra, mindkettő külön adatmező lesz (dátum formátumban), majd a pivotba is így teszed be őket egymás mellé (szintén minimum, vagy maximum függvényt illesztve rá)
-
-
ulrik19
tag
válasz
mr.nagy
#6411
üzenetére
egyelőre nem nézegettem meg jobban a kódod, de nem értem, hogy kerül a képbe a windows objektum. Ne keverd a workbooks-szal.
Persze azt nem tudom, hogy függ ez össze azzal, hogy egyik gépen megy, a másikon meg nem. (lehet, hogy valamelyik hiányolja a névnél a .xls kiterjesztést? esetleg túl hosszú a filenév, és valamiért dos-osként kezeli 8.3 módon?)
egyébként csatlakoznék a kód tömörítésére tett javaslathoz.
-
#6420
Fire/SOUL/CD
félisten
mr.nagy
#6418
válasz
mr.nagy
#6418
üzenetére
Hali!
Tehát akkor összefoglalnám. Minden gépen ugyanolyan verziójú és szervízpakkal elátott XP fut, valamint ugyanolyan verziójú és szervízpakkal ellátott Office 2003, ennek ellenére az asztali gépeken működik a makród kifogástalanul, míg a noti(ko)n/laptop(oko)n nem?
Nincs esetleg Visual Basic telepítve külön? (vagy az asztalikra vagy a notikra)
Fire.
-
#6416
Fire/SOUL/CD
félisten
mr.nagy
#6415
-
#6412
Fire/SOUL/CD
félisten
mr.nagy
#6411
-
#6299
Fire/SOUL/CD
félisten
mr.nagy
#6297
-
ulrik19
tag
válasz
mr.nagy
#6238
üzenetére
Csinálsz egy "végeredmény" táblát, amiben benne vannak a plusz oszlopok is (gondolom megbújik benne szinte valamennyi oszlop a kimutatásból)
A sorok száma ezek szerint változó, de nem is lényeges.
Az átszívandó oszlopokra tudsz hivatkozni: pl. =adattabla!A5 (ha a kimutatás az adattabla nevű sheeten van, és az A oszlop adata kell, ami az 5-ös sortól indul)
Amikor a képletet lefelé másolod, a következő adatsort veszi a kimutatásból.
Minden egyes oszlopnál ezt beállítod, köztük simán lehet olyan oszlop, amit Te töltögetsz.
-
ulrik19
tag
válasz
mr.nagy
#6234
üzenetére
Szia, ha nem változik a kimutatástábla szerkezete (sorok és oszlopok száma), akkor simán tudsz az adott cellára hivatkozni máshol (pl. =F8)
Persze akkor is tudsz hivatkozni bármelyik adatra ilyen formában, ha változik a tábla szerkezete, de akkor nyomok kell követni a változást.
Egyébként van olyan fajta linkelési (adatkinyerési) mód, amikor nem a konkrét cellára hivatkozol, hanem magára az adatra (melyik adatsor, vagyis hónap, melyik oszlopadata), ezáltal ha változik a megjelenítési helye, akkor is tudja kezelni.
De először tudni kell, hogy mennyire változó a tábla.
![;]](http://cdn.rios.hu/dl/s/v1.gif)
Új hozzászólás Aktív témák
Hirdetés
Fferi50
- BESZÁMÍTÁS! ASUS A520M R5 5600X 16GB DDR4 512GB SSD RTX 3060Ti 8GB Rampage SHIVA Enermax 650W
- BESZÁMÍTÁS! Intel Core i9 14900KF 24 mag 32 szál processzor garanciával hibátlan működéssel
- BESZÁMÍTÁS! ASUS ROG CROSSHAIR VI EXTREME alaplap garanciával hibátlan működéssel
- MacBook felváráslás!! MacBook, MacBook Air, MacBook Pro
- Okosóra felvásárlás!! Samsung Galaxy Watch 5 Pro, Samsung Galaxy Watch 6 Classic
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: PC Trade Systems Kft.
Város: Szeged