-
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
-
#29264
Delila_1
veterán
coldfirexx
#29262
Delila_1
veterán
válasz
coldfirexx
#29262
üzenetére
Átírtad a lapok nevét a makróban szereplő egyes és kettes névről a sajátodra?
If CV = "IGEN" Then Cells(CV.Row, "F").Copy Sheets("kettes").Cells(ide, "A")
A fenti sor kiemelt része végzi a beillesztést.
-
#29261
Delila_1
veterán
irodakukac
#29236
Delila_1
veterán
válasz
irodakukac
#29236
üzenetére
Ny.janos javaslatára megírtam az új makrót.
Az Összes... lapodon jelöld ki a tartományodat. Beszúrás | Táblázat. A neve legyen Összes. A másik lapon a W1-be másold be az első lap H oszlopának a címét, a W2-be írd be: készpénz.
A makró (modulban) ennyi
Sub Spec_Szures()
Sheets("házipénztár").Select
Sheets("Összes könyvelési adat").Range("Összes[#All]").AdvancedFilter Action _
:=xlFilterCopy, CriteriaRange:=Range("W1:W2"), CopyToRange:=Range("A1:T1"), _
Unique:=False
End SubAhányszor indítod ezt a makrót, a házipénztár lapodon mindig a friss, kp-s sorok jelennek meg.
Ha az Összes... lapodra teszel indítógombot, azt is mindig átmásolja, ezért nem érdemes oda tenni. Tedd inkább a másik lapra. -
#29259
Delila_1
veterán
coldfirexx
#29251
Delila_1
veterán
válasz
coldfirexx
#29251
üzenetére
Itt a makró:
Sub Nevek()
Dim usor As Long, ter As Range, ide As Long, CV As Range
usor = Range("H" & Rows.Count).End(xlUp).Row
Set ter = Sheets("egyes").Range("H3:H" & usor).CurrentRegion
For Each CV In ter
ide = Sheets("kettes").Range("A" & Rows.Count).End(xlUp).Row + 1
If CV = "IGEN" Then Cells(CV.Row, "F").Copy Sheets("kettes").Cells(ide, "A")
Next
End SubModulba kell tenned, ahogy a Téma összefoglalóban le van írva.
Szerk.: a válasz elküldése után jutottam az olvasásban oda, hogy kaptál egyszerű, nem makrós megoldást.
-
#29237
Delila_1
veterán
irodakukac
#29236
Delila_1
veterán
válasz
irodakukac
#29236
üzenetére
Szívesen. Nehogy hamar megöregedj!
-
#29235
Delila_1
veterán
irodakukac
#29233
Delila_1
veterán
válasz
irodakukac
#29233
üzenetére
A modulba írtat kiegészítettem azzal, hogy a házipénztár lap előző adatait törölje az új másolás előtt.
Sub Hó_Eleji_KpMásolás()
Dim usor As Long, ter As Range
usor = Range("A" & Rows.Count).End(xlUp).Row
'Előző adatok törlése a házipénztár lapon
Set ter = Sheets("házipénztár").Range("A1").CurrentRegion
ter.Offset(1, 0).Resize(ter.Rows.Count - 1, ter.Columns.Count - 1).ClearContents
'Szűrés készpénzre
ActiveSheet.Range("$A$1:$T$" & usor).AutoFilter Field:=8, Criteria1:="készpénz"
'Szűrt sorok másolása
Range("A2:T" & usor).SpecialCells(xlCellTypeVisible).Copy Sheets("házipénztár").Range("A2")
'Szűrés megszüntetése
ActiveSheet.Range("$A$1:$T$" & usor).AutoFilter Field:=8
End Sub -
#29234
Delila_1
veterán
irodakukac
#29233
Delila_1
veterán
válasz
irodakukac
#29233
üzenetére
Szia!
Írtam egy másik makrót, ami megoldja a hóeleji másolást. Ezt a makrót modulba tedd (a Téma összefoglaló szerint). Most írtam bele néhány megjegyzést, hogy tudd, melyik sor mire való.
Sub Hó_Eleji_KpMásolás()
Dim usor As Long, usorHP
usor = Range("A" & Rows.Count).End(xlUp).Row
usorHP = Sheets("házipénztár").Range("A" & Rows.Count).End(xlUp).Row + 1
'Szűrés készpénzre
ActiveSheet.Range("$A$1:$T$" & usor).AutoFilter Field:=3, Criteria1:="készpénz"
'Szűrt sorok másolása
Range("A2:T" & usor).SpecialCells(xlCellTypeVisible).Copy Sheets("házipénztár").Range("A" & usorHP)
'Szűrés megszüntetése
ActiveSheet.Range("$A$1:$T$" & usor).AutoFilter Field:=3
End SubÉrdemes kitenni egy gombot. Lehet ez egy csinos alakzat a felső sorban. Jobb klikk rajta, Makró-hozzárendelés, majd kiválasztod – ha van választék
– a Hó_Eleji_KpMásolás-t. Ez a kényelmesebb módszer, de gomb nélkül is indíthatod pl. az Alt+F8-as megoldással.Szerk.: A laphoz rendelt makróban lesz egy apró változás, hogy ne fusson hibára, mikor hó elején a sok adatot egyszerre bemásolod. A csillagos sor új.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ide As Long, sor As Long
If Target.Count > 1 Then Exit Sub '**********
If Target.Column = 20 Then
sor = Target.Row
If Range("H" & sor) = "készpénz" Then
ide = Application.WorksheetFunction.CountA(Sheets("házipénztár").Columns(1)) + 1
Range("A" & sor & ":T" & sor).Copy Sheets("házipénztár").Range("A" & ide)
End If
End If
End Sub -
#29227
Delila_1
veterán
FozzieBear
#29223
Delila_1
veterán
válasz
FozzieBear
#29223
üzenetére
Nosza, ne fogd vissza magad. Szerintem jobb lenne az Excel 2016+ cím, ami jelzi, hogy a 2016-os verziótól kezdődik.
-
Delila_1
veterán
Szerintem meghülyíted a folytonos rákérdezéssel a felhasználót. Inkább vegyél fel egy új oszlopot, ahova újra be kell vinni az adatot, majd feltételes formázással színezd ki a két cellát, ha nem egyformák (kép jobb oldalán).
A másik kérdésre: a D1 cella tartalmazza a normát, az F1 a max. eltérést. Ha a bevitt érték a megadott tűrés alatt-, ill. fölött van, a háttérszín jelez (kép bal oldalán).
Egy ábrára tettem a két kérdésnek feltételes formázással való megoldását, a képletek a megjegyzésekben láthatóak.
-
#29218
Delila_1
veterán
germinator66
#29217
Delila_1
veterán
válasz
germinator66
#29217
üzenetére
-
#29216
Delila_1
veterán
germinator66
#29215
Delila_1
veterán
válasz
germinator66
#29215
üzenetére
Örülök, hogy sikerült.
-
#29214
Delila_1
veterán
germinator66
#29213
Delila_1
veterán
válasz
germinator66
#29213
üzenetére
Kijelölöd a tartományt, ami pl. A2-től Z100-ig tart. Ebben a tartományban akarod azt a sort színezni, ahol pl. a H oszlopban van bármilyen karakter. A képlet
=$H2>"" (két db idézőjel)
-
#29205
Delila_1
veterán
irodakukac
#29204
Delila_1
veterán
válasz
irodakukac
#29204
üzenetére
Nagyon szívesen.
A T oszlopot a
If Target.Column = 20 Then
sor figyeli, a 20 helyett annak az oszlopnak a számát írd be, amelyikre reagálnia kell az eseményvezérelt makrónak. A=1, B=2, .... T=20.
-
#29202
Delila_1
veterán
irodakukac
#29201
Delila_1
veterán
válasz
irodakukac
#29201
üzenetére
A házipénztárban megmarad a rongyos régi (azt manuálisan kell törölnöd), a módosított bekerül az első üres sorba. Persze csak akkor, mikor a sorban a T oszlop adatát leenterezed a szerkesztőlécen.
Mindig csak az a sor kerül át a másik lapra, ahol a T oszlopba viszel be adatot.
-
#29200
Delila_1
veterán
irodakukac
#29196
Delila_1
veterán
válasz
irodakukac
#29196
üzenetére
Akkor másol, mikor az utolsó (T) oszlopba beírod az adatot. Míg nincs kitöltve a teljes sor, addig nem érdemes másolni.
Jól csináltál mindent. A füzetet makróbarátként kell mentened.
-
#29197
Delila_1
veterán
irodakukac
#29196
Delila_1
veterán
válasz
irodakukac
#29196
üzenetére
Az Összes...-be viszed be az adatokat, innen másolja a házipénztár lap első üres sorába azt az újonnan bevitt sort, ahol a H oszlopban készpénz szerepel. Azt írtad, az előzőleg bevitt sorokat már átmásoltad. Ha mégsem, legalább fejléc legyen a házipénztár lapon.
-
#29195
Delila_1
veterán
irodakukac
#29194
Delila_1
veterán
válasz
irodakukac
#29194
üzenetére
A Rows(sor).Copy Sheets("házipénztár").Range("A" & ide) helyett inkább írj
Range("A" & sor & ":T" & sor).Copy Sheets("házipénztár").Range("A" & ide) -t.
Később jöttem rá, hogy a házipénztár lapod U oszlopában valami képlet szerepelhet.
Az első a teljes sort másolja, kitörölve ezzel az U képletét. -
#29193
Delila_1
veterán
irodakukac
#29192
Delila_1
veterán
válasz
irodakukac
#29192
üzenetére
A lenti makrót az Összes könyvelési adat lapodhoz rendeld. Ennek a módja szerepel a Téma összefoglalóban.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ide As Long, sor As Long
If Target.Column = 20 Then
sor = Target.Row
If Range("H" & sor) = "készpénz" Then
ide = Application.WorksheetFunction.CountA(Sheets("házipénztár").Columns(1)) + 1
Rows(sor).Copy Sheets("házipénztár").Range("A" & ide)
End If
End If
End Sub -
#29191
Delila_1
veterán
irodakukac
#29190
Delila_1
veterán
válasz
irodakukac
#29190
üzenetére
Még azt add meg, melyik az utolsó oszlop, amit az egyes sorokban kitöltötök.
Mikor ide beírjátok az adatot, a H oszlop tartalmától függően automatikusan átmásolódik majd a teljes sor a házipénztár lap első üres sorába. Melyiket (átutalás, vagy készpénz) másoljuk?
-
#29189
Delila_1
veterán
irodakukac
#29188
Delila_1
veterán
válasz
irodakukac
#29188
üzenetére
Az Összes ... lap melyik oszlopa tartalmazza a fizetés módját?
A szöveg így szerepel: készpénz/átutalás , vagy készpénz, vagy átutalás?
-
Delila_1
veterán
válasz
lenkei83
#29185
üzenetére
Nálam a legördülők eredménye a Munka1!B1 cellában van, az adatok a Munka2 lapon helyezkednek el.
Sub OsszegzesFeltetellel()
Dim cim As String, terulet As Range, CV As Range, MitKeres As Variant
Set terulet = ActiveSheet.UsedRange
MitKeres = Sheets("Munka1").Range("B1")
For Each CV In terulet
If CV = MitKeres Then cim = cim & "Munka2!" & CV.Address & "+"
Next
cim = Left(cim, Len(cim) - 1)
Sheets(1).Range("A1") = "=" & cim
End Sub -
Delila_1
veterán
válasz
lenkei83
#29183
üzenetére
Még mindig nem értem, miért ilyen bonyolultan összegzel.
Dim osszeg As Variant, terulet As Range, CV As Range
Set terulet = ActiveSheet.UsedRange
For Each CV In terulet
If IsNumeric(CV) Then osszeg = osszeg + CV
Next
Sheets(1).Range("A1") = osszegAz osszeg változó azért variant, mert nem tudom, egész-, vagy tört számaid vannak-e.
-
-
#29124
Delila_1
veterán
szatocs1981
#29123
Delila_1
veterán
válasz
szatocs1981
#29123
üzenetére
Jogos a felvetés.
-
#29122
Delila_1
veterán
szatocs1981
#29121
Delila_1
veterán
válasz
szatocs1981
#29121
üzenetére
Szerintem
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then Cells(Target.Row, 1) = Date
End Subis elég.
-
#29119
Delila_1
veterán
szatocs1981
#29118
Delila_1
veterán
válasz
szatocs1981
#29118
üzenetére
A adatbevitel végén az A oszlop képleteit értékként önmagukra kell másolni, másképp holnap a holnapi dátumok szerepelnek ott.
-
Delila_1
veterán
válasz
karlkani
#29097
üzenetére
Szerintem akkor is kell törölni az I értékét és a megjegyzést, ha a D és H közül csak az egyiket törlöd. Másképp minek az eredménye van az I-ben?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sor As Long, szoveg As String, osszeg As Double
sor = Target.Row
If Target.Column = 4 Or Target.Column = 8 And Target.Row > 1 Then
Application.EnableEvents = False
If IsNumeric(Cells(sor, "D")) And IsNumeric(Cells(sor, "H")) _
And Cells(sor, 4) <> "" And Cells(sor, 8) <> "" Then
osszeg = Round(Cells(sor, "H") - Cells(sor, "D") * 8, 1)
With Range("I" & sor)
On Error Resume Next
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
szoveg = "I/D=" & osszeg & "/10=" & Format(osszeg / 10, "# ##0.0") & " Ft/liter"
.Comment.Text Text:=szoveg
Selection.AutoSize = True
Selection.Visible = False
End With
Cells(sor, "I") = Format(osszeg, "# ##0.0 Ft/liter")
Else
Cells(sor, "I") = ""
Cells(sor, "I").Comment.Delete
End If
Range(Target.Address).Select
Application.EnableEvents = True
End If
End Sub -
Delila_1
veterán
válasz
modflow
#29086
üzenetére
A listából kiválasztást a laphoz rendelt makró figyeli.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$3" Then Ugras Target
End SubEz meghívja a modulba írt, Ugras nevű makrót, és átadja a kiválasztott értéket.
Ez a makró hajtja végre az ugrást az általad megadott lapra, és a megadott cellára. A Case utasításokban bármi más feladatot is megadhatsz.Sub Ugras(ide)
Select Case tg
Case "alma"
Sheets("AAA").Activate: Range("A1").Select
Case "körte"
Sheets("BBB").Activate: Range("C5").Select
Case "szilva"
Sheets("CCC").Activate: Range("B10").Select
Case "naspolya"
Sheets("DDD").Activate: Range("H12").Select
End Select
End Sub -
Delila_1
veterán
válasz
karlkani
#29083
üzenetére
Mivel az I oszlopban a D és H cellákkal kell számolni, az eseményvezérelt makróban ennek a két oszlopnak a változását kell figyeltetni.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sor As Long
sor = Target.Row
If Target.Column = 4 Or Target.Column = 8 And Target.Row > 1 Then
Application.EnableEvents = False
If IsNumeric(Cells(sor, "D")) And IsNumeric(Cells(sor, "H")) And Cells(sor, 4) <> "" And Cells(sor, 8) <> "" Then
Cells(sor, "I") = Format((Cells(sor, "H") - Cells(sor, "D") * 8), "# ##0.00 Ft/liter")
Range(Target.Address).Select
End If
Application.EnableEvents = True
End If
End SubA Cells(sor, "I") =... értékadásnál az általad megadott képletet [=HA(D="";"";H-D*8)] alkalmaztam.
A sor változót csak azért iktattam be, mert többször szerepel a makróban, és egyszerűbb leírni, mint a Target.Row-t. Na meg rövidebbek is az utasítások. -
Delila_1
veterán
válasz
MCGaiwer
#29071
üzenetére
Töltöd folyamatosan az első lap táblázatát. Ezekről az eseményvezérlő makró 20 oszloppal jobbra másolatot készít. Nem írtad, hány oszlopba viszed fel az adatokat, gondoltam, elég lesz az első 20.
Kezded kitölteni a táblázatodat, a 2. (B) oszloptól kezdve. Mikor beviszel egy adatot a B oszlopba, a makró megnézi, van-e már a 20-szal jobbra lévő (V) oszlopban érték. Ha nincs, oda másolja a bevitt értéket, majd az aktuális sor A oszlopába beírja az aktuális dátumot. Folytatod a táblázat kitöltését a következő oszloppal. Nem fontos minden oszlopba írnod, következzen most a D (4. oszlop) értékének a bevitele. A makró megint megnézi, hogy a 4+20-adik oszlopban van-e már eltárolva érték. Ha nincs, az aktuális sor 1:4 oszlopát értékként beilleszti a 20+1 oszloptól kezdve. Ha van, nem módosítja, másképp nem tudod az eredetit visszaállítani.
Így folyamatosan másolatot készít az eredetileg bevitt értékekről 20 oszloppal jobbra.Másnap megváltoztatod a D értékét. A makró látja, hogy van már adat a 24. oszlopban, nem módosít. Később rájössz, hogy az eredetileg bevitt érték volt jó. Ekkor beállsz a kérdéses sorba, és indítod a gombbal a visszaállítást. A gombhoz rendelt Elozo_Click megállapítja az aktuális sor utolsó kitöltött oszlopát (24), és a V (22.) oszloptól eddig másolja az adatokat, értékként beilleszti a B oszloptól. Tehát a régi dátum kivételével felülírja az eredeti táblázat aktuális sorát az előzően bevitt adatokkal, majd az A oszlopba beírja az aktuális dátumot.
Elég nehéz lehet ezt így követni, de a kérdésedet is, ami az első felvetésed óta többször változott. Talán legjobb lenne a kályhától kiindulva, az eddigi kérdéseket mellőzve pontosan leírnod, mire van szükséged.
-
Delila_1
veterán
válasz
MCGaiwer
#29065
üzenetére
A "B" lap A2 cellájának a képlete =HA(A!A2="";"";A!A2). Azért nem simán =A!A2, hogy ne rajzolja tele a lapot nullákkal üres A!cella esetén. A képletet másold jobbra és le, ameddig kell.
Az "A" lapon 1 gomb van a vezérlők eszköztárából, ami nálam Elozo névre hallgat. Ehhez a laphoz 2 makrót rendelj. Mindkettő csak a saját lapján dolgozik, mert a "B" lapon a képletek adják a mindenkori "A" lap értékekeit. Az első eseményvezérelt,
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oszlop As Integer, uoszlop As Integer
Application.EnableEvents = False
If Target.Row = 1 Then Exit Sub
If Cells(Target.Row, Target.Column + 20) = "" Then
uoszlop = Cells(Target.Row, 20).End(xlToLeft).Column
Range(Cells(Target.Row, 1), Cells(Target.Row, uoszlop)).Copy
Range("U" & Target.Row).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Cells(Target.Row, 1) = Date
Range(Target.Address).Activate
End If
Application.EnableEvents = True
End SubEz a makró másolatot készít az aktuális sor adatairól, az U oszloptól kezdődően. Ha sok oszlopod van, teheted hátrább is. Az aktuális dátumot beírja az A oszlopba.
A második makró a gombhoz rendelt.
Private Sub Elozo_Click()
Dim sor As Long, oszlop As Integer, uoszlop As Integer
sor = Selection.Row: oszlop = Selection.Column
uoszlop = Cells(sor, Columns.Count).End(xlToLeft).Column
Application.EnableEvents = False
Range(Cells(sor, "V"), Cells(sor, uoszlop)).Copy
Range("B" & sor).PasteSpecial xlPasteValues
Range("A" & sor) = Date
Cells(sor, oszlop).Activate
Application.CutCopyMode = False
Application.EnableEvents = True
End SubMűködése: állj a sorra, ahol vissza akarod csalni az előző adatokat, majd klikkelj a gombra. A V oszloptól kezdve az első makró által beírt utolsó adatig másol a B oszlopba, az A-ba beírja az aktuális dátumot.
Ha a régi dátumot is vissza akarod állítani, akkor a másolás az U-tól kezdődjön, a célcella pedig range("A" & sor) legyen. Ekkor nem kell a range("A" & sor)=date sor.
-
Delila_1
veterán
válasz
Marki1987
#29045
üzenetére
Az A oszlopban vannak az érvényesítések, a többiben a megfelelő oszlopban X lesz.
A B2 cella képlete látható a megjegyzésben, ezt a képletet másold jobbra, és le.
A képletben nem fontos a címsorra hivatkoznod (A2=B$1), hanem beírod, melyik választáskor tegyen X-et abba az oszlopba.
-
#29054
Delila_1
veterán
m.zmrzlina
#29053
Delila_1
veterán
válasz
m.zmrzlina
#29053
üzenetére
Minek az ÖSSZEFŰZ? Azt olyan nehéz magyarul, és angolul is leírni.
= MID(A1,SEARCH(" ",A1)+1,50) &" " & UPPER(LEFT(A1,SEARCH(" ",A1)-1))
Hossznak a MID függvényben a LEN(A1)-et is adhatnám, de az 50 karakter biztosan elég.
-
Delila_1
veterán
válasz
alfa20
#29032
üzenetére
Másik módszer
Dim fent As Double, bal As Double, usor
fent = Range("F" & Range("F" & Rows.Count).End(xlUp).Row).Offset(3).Top
bal = Range("F1").Left
ActiveSheet.Buttons.Add(bal, fent, 72, 26).Name = "Gomb"A gomb kívánt szélességét és magasságát add meg a 72 és a 26 helyett.
-
-
-
Delila_1
veterán
válasz
Tsabee
#28987
üzenetére
Javaslom, hogy a ThisWorkbook lapra a 2. makrót másold, ami az RGB színeket tartalmazza.
Neked kell összeállítani a segédtáblát. Mivel soronként 32 adatod van, a táblázatot az AN oszlopban kezdd, ahogy a képen látod.
Természetesen az AN oszlopba a saját számaidat írd, és a saját ízlésed szerint színezd. Mikor kész a segédtábla az N oszlopig, ráállsz az első (AN3) cellára, és indítod a SzínLekerdezes makrót. Ilyen üzenetet kapsz:
Egyenként minden számodhoz írd be a kódokat a megfelelő helyekre.
A laphoz rendelt makró változik:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sor As Long
If Target.Column > 1 And Target.Column <= 33 Then
On Error Resume Next
sor = Application.Match(Target, Columns(40))
If VarType(sor) = vbError Then
Exit Sub
Else
Range(Target.Address).Interior.Color = RGB(Cells(sor, "AO"), Cells(sor, "AP"), Cells(sor, "AQ"))
Range(Target.Address).Font.Color = RGB(Cells(sor, "AR"), Cells(sor, "AS"), Cells(sor, "AT"))
End If
End If
End SubA sorszámok ismétlésének a módját már leírtam.
A képen látható B1:F1 tartomány számait a makró színezte ki, én csak beírtam.
-
Delila_1
veterán
válasz
Tsabee
#28983
üzenetére
Pontosabb, egyéni színkódokat is beállíthatsz. Az első makró helyett legyen
Sub SzinLekerdezes()
Dim Rh As Integer, Gh As Integer, Bh As Integer
Dim Rk As Integer, Gk As Integer, Bk As Integer
Dim hatter, karakter
hatter = Selection.Interior.Color
karakter = Selection.Font.Color
Rh = hatter Mod 256
Gh = (Int(hatter / 256)) Mod 256
Bh = Int(hatter / 256 ^ 2)
Rk = karakter Mod 256
Gk = (Int(karakter / 256)) Mod 256
Bk = Int(karakter / 256 ^ 2)
MsgBox "Háttér RGB: " & Rh & ", " & Gh & ", " & Bh & vbLf & _
"Karakter RGB: " & Rk & ", " & Gk & ", " & Bk
End Suba második helyett pedig ez
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sor As Long
If Target.Column = 1 Then
On Error Resume Next
sor = Application.Match(Target, Range("N:N"))
If VarType(sor) = vbError Then
Exit Sub
Else
Range(Target.Address).Interior.Color = RGB(Cells(sor, "O"), Cells(sor, "P"), Cells(sor, "Q"))
Range(Target.Address).Font.Color = RGB(Cells(sor, "R"), Cells(sor, "S"), Cells(sor, "T"))
End If
End If
End SubEhhez a segédtáblát is bővítened kell.
Az A6 cella 86-os értéke az előző makrókkal készültek, ott nem tudta hozni az egyéni háttérszínt.
-
Delila_1
veterán
válasz
Tsabee
#28983
üzenetére
Kezdjük az egyszerűbbel. Beírod a sorszámokat 1-től 7-ig. Mivel nem adtad meg, hol kellenek ezek a számok, az A1-ben kezdtem. Az A8 képlete =A1, ezt másolhatod, ameddig kell.
A másikhoz 2 makró szükséges.
Alt+F11-gyel belépsz a makró szerkesztőbe. Bal oldalon kiválasztod a füzetedet, ott is a ThisWorkbook lapot. A jobb oldalon kapott nagy fehér felületre bemásolod a makrót:Sub Szin_lekerdezes()
MsgBox "Háttér színkód: " & Selection.Interior.ColorIndex & vbLf & _
"Karakter színkód: " & Selection.Font.ColorIndex
End SubEz azt csinálja, hogy kiírja egy üzenetben az aktív cella hátterének, és karakterének a színkódját.
Összeállítasz egy segédtáblát, ahol az első oszlop tartalmazza a bevihető, színezendő számokat, a 2. oszlop a háttér-, a 3. a karakter színkódja lesz. Nálam ez a segédtábla az N:P oszlopokban van. Az N oszlopban beállítod a kívánt 2 színt, majd ráállsz az első számra, és indítod a fenti makrót (Alt+F8-ra megjelenő ablakban). A két kapott értéket beírod a megfelelő helyre. Ezt egyszer kell végig zongoráznod.Most jön a bevitt számok cellájának az automatikus színezése.
Azt sem írtad meg, hova viszed be ezeket a számokat. A lenti makró az A oszlopba beírt számok celláját színezi. Ezt a makrót a lapodhoz kell rendelni. Lapfülön jobb klikk, újra a VB szerkesztőben vagy, abban is a lapodhoz tartozó üres felület jelent meg a jobb oldalon. Oda kell bemásolnod a kódot:Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
On Error Resume Next
Range(Target.Address).Interior.ColorIndex = _
Application.WorksheetFunction.VLookup(Target, Range("N:P"), 2, 0)
Range(Target.Address).Font.ColorIndex = _
Application.WorksheetFunction.VLookup(Target, Range("N:P"), 3, 0)
End If
End SubEzzel kész az előkészület.
Mikor beírsz egy számot az A oszlopba azok közül, amiket a segédtáblában megadtál, a kedvenc színösszeállításodra színezi a cellát. Olyan szám beírásánál, ami nem szerepel a segédtáblában, marad az eredeti háttér- és karakterszín.Kép hozzá:
-
Delila_1
veterán
válasz
csadi0011
#28980
üzenetére
Néhány dolgot nem írtál meg. Az 1-es lapon hol van ez a bővülő sor? Ebbe a sorba billentyűzetről viszed be az adatokat, vagy képlet írja be az új értékeket? Hol legyen a szelektált sor?
Írtam egy makrót, ahol a lap első sorában vannak a jelenlegi adatok (pillanatnyilag 56 db, az A1:BD1 tartományban), és ebből az egyedi értékeket a 2. sorba írja be abban a sorrendben, ahogy az elsőben előfordulnak. A makrót a lapodhoz kell rendelned.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oszlop As Long, uoszlop As Long, CV As Object
If Target.Row = 1 Then
Application.EnableEvents = False
oszlop = 1
uoszlop = Range("A1").End(xlToRight).Column
Rows(2) = ""
For Each CV In Range(Cells(1, 1), Cells(1, uoszlop))
If Application.WorksheetFunction.CountIf(Rows(2), CV) = 0 Then
Cells(2, oszlop) = CV
oszlop = oszlop + 1
End If
Next
Application.EnableEvents = True
End If
End SubKérlek, olvasd el a Téma összefoglalót, és legközelebb az ott leírtaknak megfelelően tedd fel a kérdésedet!
-
Delila_1
veterán
Ha jól értem, a Munka1 lap D oszlopában lévő cikkszámokat (vagy miket) kell színezni, ha a Munka2 lap C oszlopában (Lista tartomány) szerepel a bal oldaluk, változó hosszban.
A Munka1!D:D és a Munka2!C:C formátuma legyen szöveg. A Munka1 D oszlopában a feltételes formázás képlete
=HAHIBA(HOL.VAN(BAL(D1;SZÖVEG.KERES("-";D1)-1);Lista;0);HOL.VAN(D1;Lista;0))
-
Delila_1
veterán
válasz
lenkei83
#28948
üzenetére
Range("A2:A20") = "=SUMIF(INDIRECT(""'"" & F2 & ""'!A:A""),B2,INDIRECT(""'"" & F2 & ""'!V:V""))"
Ez a képlet az A2:A20 tartományba beírja a
=SZUMHA(INDIREKT("'" & F2 & "'!A:A");B2;INDIREKT("'" & F2 & "'!V:V")) képletet.Az elsőnél a lapnév az F2 cella értéke, a kritérium a B2 cella. A következő sorban ezek F3 és B3-ra változnak. Ha a kritériumot nem akarod módosítani, akkor B$2-t írj.
Ezt már módosíthatod SUMIFS-re.
-
Delila_1
veterán
válasz
qsotre
#28928
üzenetére
Feltételes formázást adj az A5:C7, majd a D5
7 tartományra. A sorszámok és oszlopazonosítók nem látszanak a képen, de úgy látom, ezekben a tartományokban vannak az adataid.Az első képlet az első tartományra a feltételes formázásnál =ÉS($B5<=$A$10;$C5>=$A$10), a másik a következő tartományra =ÉS($E5<=$A$10;$D5>=$A$10).
Az A10 tartalmazza a lopás időpontját. Ezt vajh' ki és hogyan állapítja meg?
-
Delila_1
veterán
válasz
kobak82
#28853
üzenetére
Kijelölöd a 3 oszlopodat, Beszúrás, Kimutatás.
Kapsz egy ablakot, ahol megadhatod a kimutatás helyét (új lapra akarod tenni, vagy az aktuális lap ... cellájában kezdődjön).
Újabb ablak jön fel. Felül van a 3 oszlopod címe. Ezeket húzod le az ablak alján lévő, az előbbiekben leírt helyekre. Ezzel kész.
Még azt teheted meg, hogy amit sorcímkének vettél fel, a kész kimutatásban annak a legördülőjében kiveszed a pipát az (üres) elől.
Ha bővül, változik az eredeti táblázatod, a kimutatáson jobb klikk, frissítést választasz.
Nem javaslom a képletekkel való megoldást. Ahhoz előbb a név, és város oszlopodból speciális szűréssel ki kell íratnod az egyedi értékeket, a kapott adatok közül az egyiket transzponálnod kell, ezután jöhet a DARABHATÖBB képletek beírása.
-
Delila_1
veterán
-
Delila_1
veterán
Sub Masolas()
Dim sor As Long
sor = 2
Do While Sheets("Sheet1").Cells(sor, "A") <> ""
Sheets.Add.Name = "Sheet" & sor
ActiveSheet.Move After:=Sheets(Sheets.Count)
Sheets("Sheet1").Range("A" & sor).Copy Sheets("Sheet" & sor).Range("B3")
sor = sor + 1
Loop
End SubCímsort feltételezve az első lap 2. sorától indítottam (sor=2).
-
-
Delila_1
veterán
-
-
#28682
Delila_1
veterán
antikomcsi
#28680
Delila_1
veterán
válasz
antikomcsi
#28680
üzenetére
Akkor lesz egy nagyon vidám, hosszú képleted. Ha-Ha-Ha. Ha az első lapon hibára fut az fkeres (mert nincs találat), akkor fkeres(2.lapon), ha ez is hibás, fkeres(3.lapon), stb.
Közben összeállítottam a képletet. A lapjaim neve első, más, har, negy.
=HAHIBA(FKERES(E2;első!A1:L126;12;0);HAHIBA(FKERES(E2;más!A1:L126;12;0);HAHIBA(FKERES(E2;har!A1:L126;12;0);HAHIBA(FKERES(E2;negy!A1:L126;12;0);""))))
-
Delila_1
veterán
válasz
Snoop-y
#28671
üzenetére
A D1 cellába beírja az összeget, szűrt állományban is.
Sub valami()
Dim ter As Range, CV As Range, osszeg
Set ter = Columns(1).SpecialCells(xlCellTypeVisible)
For Each CV In ter
If CV.Row > 1 And Cells(CV.Row, "B") > "" Then osszeg = osszeg + CV
Next
Range("D1") = osszeg
End Sub
7 tartományra. A sorszámok és oszlopazonosítók nem látszanak a képen, de úgy látom, ezekben a tartományokban vannak az adataid.
Új hozzászólás Aktív témák
- HP Z4 G4 / Xeon W-2123, nvidia P4000, 24GB RAM, 256gb SSD, 4TB HDD
- GYÖNYÖRŰ iPhone 12 Pro 256GB Pacific Blue-1 ÉV GARANCIA -Kártyafüggetlen, MS4339, 100% Akksi
- Bomba ár! HP EliteBook 2570P - i7-3GEN I 8GB I 128SSD I DVDRW I 12,5" HD I W10 I Garancia!
- HP ProBook 445 G8 14" Ryzen 3 5400U, 8GB RAM, 256GB SSD, jó akku, számla, 6 hó gar
- iking.hu Apple MacBook Pro 16 (2021) 16GB / 512GB használt, szép állapot 82% akku 353 ciklus
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest