-
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
-
Delila_1
veterán
válasz
slashing
#23400
üzenetére
Azért egy másik, ami azt figyeli, hogy a saját felhasználói neveddel léptél-e be.
Sub mmmm()
Dim nev$
nev$ = Application.InputBox("Add meg a neved!", "Név bekérése", , , , , , 2)
If nev$ <> Environ("username") Then
MsgBox ("Te kis huncut, nem vagy jogosult a füzetet használni!"), vbOKOnly + vbExclamation
Exit Sub
Else
MsgBox "Tovább..."
'makró többi része
End If
End Sub -
Delila_1
veterán
válasz
slashing
#23396
üzenetére
Beviszed a neveket egy oszlopba. Táblázattá alakítod, és a Nevek névvel látod el a tartományt.
Sub mm()
Dim nev$, tomb(), v As Integer, megvan As Boolean
nev$ = Application.InputBox("Add meg a neved!", "Név bekérése", , , , , , 2)
tomb = Application.Transpose(Range("Nevek"))
For v = 1 To UBound(tomb)
If nev$ = tomb(v) Then
megvan = True
Exit For
End If
Next
If megvan = False Then
MsgBox "Nem szerepelsz a nevek között!"
Exit Sub
Else
MsgBox nev$ & " a(z) " & v & ". helyen szerepel."
'makró többi része
End If
End SubBővítheted agyba-főbe a tartományt.
-
Delila_1
veterán
válasz
slashing
#23360
üzenetére
A végét írd meg, most el kell rohannom.
Sub valami()
Dim usor As Long, uoszlop As Integer, oszlop As Integer, v$
Sheets("Munka1").Select
Range("D5").CurrentRegion.Copy Sheets("Másik lap").Range("A1")
Sheets("Másik lap").Select
usor = ActiveSheet.UsedRange.Rows.Count
oszlop = 1
Do
Columns(oszlop).EntireColumn.Insert
oszlop = oszlop + 2
Loop While Cells(1, oszlop + 1) <> ""
Columns(oszlop).EntireColumn.Insert
v$ = InputBox("add meg az értéket")
uoszlop = oszlop
For oszlop = 1 To uoszlop Step 2
Range(Cells(1, oszlop), Cells(usor, oszlop)) = v$
Next
End Sub -
-
Delila_1
veterán
válasz
Fferi50
#23329
üzenetére
A makró több formátumot módosít: a cella háttérszínét, a 4 szegély 3-3 tulajdonságát, úgy, mint stílusát, vastagságát, és színét, ami összesen 13 tulajdonság.
Igen, látszólag el lehetne tárolni ezeket, de mikor is állítanád vissza az eredeti értékeket? Mikor egy másik cellára kattint a felhasználó.
Tehát 13 publikus változóban kellene tárolni a fentieket, plusz az előzőleg kiválasztott cella címét, hogy tudjuk, melyik cella feltételes formátumát kell visszaállítani – ha egyáltalán volt rá ilyen adva. Ezeken kívül még a feltétel(eke)t is be kellene spájzolni.Eddig 1 celláról beszéltem, de a kiválasztott cellának a teljes sorát, és oszlopát módosítja a célkeresztes makró. Hány változó is kellene ehhez?
Nem tudod eltárolni az adatokat.
A célkeresztes makrót ott lehet alkalmazni, ahol nincs a lapon feltételes formázás.
-
#23332
Delila_1
veterán
WildBoarTeam
#23331
Delila_1
veterán
válasz
WildBoarTeam
#23331
üzenetére
Hurrá!
-
#23319
Delila_1
veterán
WildBoarTeam
#23316
Delila_1
veterán
válasz
WildBoarTeam
#23316
üzenetére
A kérdéses laphoz (mindegyikhez, ahol működtetni akarja) kell rendelni a lenti makrót, amit nem én írtam, de nagyon tetszik.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Cells.FormatConditions.Delete
With Target
With .EntireRow
.FormatConditions.Add Type:=xlExpression, Formula1:="1"
With .FormatConditions(1)
With .Borders(xlTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
With .Borders(xlBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
.Interior.ColorIndex = 20
End With
End With
With .EntireColumn
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="1"
With .FormatConditions(1)
With .Borders(xlLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
With .Borders(xlRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
.Interior.ColorIndex = 20
End With
End With
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="1"
.FormatConditions(1).Interior.ColorIndex = 36
End With
End Sub -
#23308
Delila_1
veterán
WildBoarTeam
#23307
Delila_1
veterán
válasz
WildBoarTeam
#23307
üzenetére
Egyszerűbb, ha a keresésnél nem a Következő, hanem a Listába mind gombot nyomod meg. A megjelenő felsorolásban egyenként nézheted meg a találatokat.
-
Delila_1
veterán
válasz
Titkárnő
#23199
üzenetére
Nem tartom jó tippnek az együvé tartozó adatok 2 sorba történő bevitelét, biztos vagyok benne, hogy slashing is csak "kínjában" javasolta.
Kicsit egyszerűsítettem a függvényen, biztosan kapsz segítséget az alkalmazásához.
Function PirosKek(rColor As Range, rRange As Range, Optional SUM As Boolean)
Dim rCell As Range, lCol As Long, vResult
lCol = rColor.Font.ColorIndex
For Each rCell In rRange
If rCell.Font.ColorIndex = lCol Then
vResult = WorksheetFunction.SUM(rCell, vResult)
End If
Next rCell
PirosKek = vResult
End FunctionAz F9-cel frissülnek az összegző értékeid.
-
Delila_1
veterán
válasz
botond187
#23203
üzenetére
Nagyon változatosan fogalmazod meg, mire van szükséged.
Eddig 6 eredményt kértél, most annyit, amennyi érték van az A oszlopodban.Írd le pontosan, milyen adatokat vársz a B oszlopba.
Például az első 6 sor tevődjön össze a kigyűjtött 6 oszlop első adataiból, a következő 6 a kigyűjtések második adatából?Ne várj azonnali választ (tőlem), egy darabig nem leszek net közelében.
-
-
Delila_1
veterán
válasz
Teejay83
#23173
üzenetére
Kipróbáltam, nem hibázik.
Kijelölöd a tartományt, Korrektúra | Változások | Tartományok szerkesztésének engedélyezése.
Megadás, itt módosíthatod a neve (címet), a hivatkozásba bekerül a tartomány címe. Megadod a jelszót, OK.Jöhet a következő tartomány engedélyezése, mint fent, végül a Lapvédelem.
-
-
Delila_1
veterán
válasz
Dolphine
#23151
üzenetére
Megírtam a 3 színhez, tudod folytatni.
Sub Piros()
Selection.Offset(-1).Font.Color = vbRed
End Sub
Sub Kek()
Selection.Offset(-1).Font.Color = vbBlue
End Sub
Sub Zold()
Selection.Offset(-1).Font.ColorIndex = 10
End SubA zöldhöz számmal adtam meg az árnyalatot, mert a vbGreen nagyon világos.
Tegyél ki 3 (5) alakzatot. Adj nekik nevet (itt Sz, I és T), és rendeld hozzájuk a megfelelő makrót.
Ezek színeznek a következő képpen: beírod a számot pl. a B4 cellába, mire a fókusz a B5-be áll. Rákattintasz a megfelelő színű alakzatra, ami az aktuális (B5) cella fölötti cella tartalmát színezi ki.
Írtam egy másik makrót, amit a lapodhoz kell rendelned. Ennek hatására az alakzatok mindig az aktuális cella mellett jelennek meg, kényelmesebbé téve a színezést.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.Shapes("Sz").Top = ActiveCell.Top
ActiveSheet.Shapes("I").Top = ActiveCell.Top
ActiveSheet.Shapes("T").Top = ActiveCell.Top
End Sub -
Delila_1
veterán
válasz
Xenon86
#23146
üzenetére
Figyelmesebben olvasva a kérdést átírtam a makrót.
Ez a K oszlopba írja be a darabszámokat.Sub HolVan()
Dim sor As Integer, sor1 As Integer
Range("L1") = "_"
Range("L2:L22") = "=B2 & L$1 & C2 & L$1 & D2 & L$1 & E2 & L$1 & F2"
Range("M2:M5") = "=H2 & L$1 & I2 & L$1 & J2"
For sor = 2 To 22
For sor1 = 2 To 5
If InStr(Cells(sor, "L"), Cells(sor1, "M")) Then
Cells(sor1, "K") = Cells(sor1, "K") + 1
End If
Next
Next
Range("L1:M22").ClearContents
End Sub -
Delila_1
veterán
válasz
Xenon86
#23146
üzenetére
A makró a futás idején segédoszlopként használja az L1:M22 tartományt, majd törli ezeket az adatokat.
Abba a sorba, ahol egyezést talál, a G oszlopba X-et ír.Sub HolVan()
Dim sor As Integer, sor1 As Integer
Range("L1") = "_"
Range("L2:L22") = "=B2 & L$1 & C2 & L$1 & D2 & L$1 & E2 & L$1 & F2"
Range("M2:M5") = "=H2 & L$1 & I2 & L$1 & J2"
For sor = 2 To 22
For sor1 = 2 To 5
If InStr(Cells(sor, "L"), Cells(sor1, "M")) Then
Cells(sor, "G") = "X"
Exit For
End If
Next
Next
Range("L1:M22").ClearContents
End Sub -
-
Delila_1
veterán
válasz
csferke
#23046
üzenetére
A lapodhoz kell rendelned a makrót.
Mikor a lapon ráállsz egy cellára, a két diagram "mellé ugrik".Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ActiveSheet.Shapes("Diagram 1")
.Top = ActiveWindow.ActiveCell.Top
.Left = ActiveWindow.ActiveCell.Left + ActiveCell.Width
End With
With ActiveSheet.Shapes("Diagram 2")
.Top = ActiveWindow.ActiveCell.Top + ActiveSheet.Shapes("Diagram 1").Height + 5
.Left = ActiveWindow.ActiveCell.Left + ActiveCell.Width
End With
End SubLehet, hogy másképp hívják a diagramjaidat, ennek megfelelően írd át a makróban a "Diagram 1", és
"Diagram 2" szövegrészeket. -
Delila_1
veterán
válasz
tgumis
#23043
üzenetére
Sosem értem, hogy a pontos feladat leírása helyett miért példálóztok.
Ha konkrétan megírnád, melyik az összefűzött cella, felsorolnád az összefűzendő cellák címét, és azt, hogy azok közül a harmadik a dátum, az ötödik pedig a kiszámított összeg, személyre szabott makrót kapnál.
Így viszont a makró tanulmányozásával valószínűleg tanulsz, és az is hasznos dolog.
-
Delila_1
veterán
válasz
tgumis
#23036
üzenetére
Rossz hír, hogy a képlettel beírt szöveget nem lehet részenként formázni, csak azt, ahova a képlettel összehozott szöveget értékként beilleszted. Erre alkalmazhatsz egy kis makrót, ami az A11-ben összefűzött szöveget az A13-ba illeszti be. Ebből a makróból indíthatod a formázást.
Sub Beilleszt()
Range("A11").Copy
Range("A13").PasteSpecial xlPasteValues
Forma
End SubSub Forma()
Dim start As Integer, hossz As Integer, szin As Integer, felk As Boolean
Dim meret As Integer
With Cells(13, 1).Characters.Font
.Name = "Arial"
.ColorIndex = 0
.Size = 10
.Bold = False
End With
start = 1: hossz = Len(Range("A1")): meret = 18: szin = 3: felk = True: GoSub Szinez
start = start + hossz + 1: hossz = Len(Range("A2")) + 1 + Len(Range("A3")) + Len(Range("A4"))
meret = 14: szin = 0: felk = True: GoSub Szinez
Exit Sub
Szinez:
With Cells(13, 1).Characters(start:=start, Length:=hossz).Font
.ColorIndex = szin
.Size = meret
.Bold = felk
End With
Return
End SubAzt azért megnézném, ahogy a lapát nyelével felásol egy területet.
-
-
Delila_1
veterán
válasz
tgumis
#22980
üzenetére
Kiteszed a vigyorit, nem zárod be a testreszabás ablakot.
A kitett ikonon jobb klikk.
Nevet adhatsz, ahol az & jel utáni karakterrel billentyűzetről is meghívhatod a hozzá rendelt makrót (nem ajánlom, mert esetleg felülírsz vele az Excel által használt billentyűkombinációt).Megváltoztathatod a gombképet. Makrót, vagy hivatkozást rendelhetsz hozzá. Meghatározhatod, hogy képet, szöveget, vagy mindkettőt meg akarod-e jeleníteni. Gombképet másolhatsz hozzá más ikonról. A Csoportkezdet az eszköztáron külön csoportba helyezi az ikont.
Még mindig megnyitott a Testreszabás ablak. Egy menüpontra klikkelve (bal gombbal) lenyílik a menü, és oda húzhatod a vigyori fejet, amit kedved szerint módosíthatsz a fent leírtak szerint.
Almenüt a Testreszabás Parancsok fülön az Új menü gombbal húzhatsz fel a kiválasztott menübe.
Ez az ikonos-gombos rész jobb, mint a későbbi verziókban. Azokban csak a fejlesztők által megrajzolt – nagyon szép, de a makró funkcióját nem tükröző – rajzokat rendelhetsz a kitett gombokhoz. Az is jó, hogy almenüket hozhatsz létre könnyedén.
-
Delila_1
veterán
válasz
rubint
#22945
üzenetére
Úgy látom, 2003-asnál magasabb verziót használsz. Ha nem, akkor a Rendezes makrót át kell alakítanod.
Az első makróban a Range("C3:K17") rész helyére írd a valós területet.Sub A_oszlopba()
Dim ertek As Range
For Each ertek In Range("C3:K17")
If ertek > "" And Not IsNumeric(ertek) Then
Range("A" & Application.WorksheetFunction.CountA(Columns(1)) + 1) = ertek
End If
Next
Rendezes
End Sub
Sub Rendezes()
Dim usor As Long
usor = Range("A" & Rows.Count).End(xlUp).Row
ActiveWorkbook.Worksheets("Munka1").Sort.SortFields.Add Key:=Range("A2:A" & usor) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Munka1").Sort
.SetRange Range("A1:A" & usor)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub -
-
Delila_1
veterán
válasz
greenface
#22910
üzenetére
Mint kiderült, nem is volt jó a kód. Az Exceledben a bővítményeknél jelöld be a két, Analyzis kezdetűt, hogy a VB szerkesztő megismerje az egyes utasításokat.
Sub Erteket_Beilleszt()
Dim FN As String
Const utvonal = "C:\Adatok\Alkönyvtár\"
Application.DisplayAlerts = False
ChDir utvonal
FN = Dir(utvonal & "*.xlsx", vbNormal)
Do
If FN <> "." And FN <> ".." Then
Workbooks.Open Filename:=utvonal & FN
Muvelet FN
ActiveWorkbook.Save
ActiveWindow.Close
End If
FN = Dir()
Loop Until FN = ""
Application.DisplayAlerts = True
End SubEzt kell indítanod, az egyes fájlok behívása után elindítja a Muvelet makrót, ami az értékek beillesztését végzi.
Sub Muvelet(FN)
Dim cella As Range
For Each cella In Sheets("material").Range("A5, A7, D10, A12, A14, B14, D14, A16, B16, C16, A18, B18")
cella = cella.Value
Next
For Each cella In Sheets("layout-volume").Range("A5, D5, A8, A10, C10, A12, C14")
cella = cella.Value
Next
Sheets("Munka1").Delete
End Sub -
Delila_1
veterán
válasz
greenface
#22902
üzenetére
2007-től működik, alatta az FN = Dir(utvonal & "*.xlsx", vbNormal) sorban az xlsx helyett írj xls-t.
A Const utvonal = "C:\Adatok\Alkönyvtár\" sorba a saját útvonaladat vidd be.
Az indító fájlodban Alt+F11-re bejön a VB szerkesztő. Bal oldalon kiválasztva a füzetedet Insert menü, Module. Jobb oldalon kapsz egy üres lapot, oda kell bemásolnod a lenti makrót.
A füzetből az Alt+F8-ra megejelő ablakban kiválasztod, és futtatod a makrót.
A füzetet makróbarátként kell mentened (2007-estől felfelé, alatta sima mentés kell).Sub Erteket_Beilleszt()
Dim FN As String
Const utvonal = "C:\Adatok\Alkönyvtár\"
Application.DisplayAlerts = False
ChDir utvonal
FN = Dir(utvonal & "*.xlsx", vbNormal)
Do
If FN <> "." And FN <> ".." Then
Workbooks.Open Filename:=utvonal & FN
Sheets("material").Range("A5, A7, D10, A12, A14, B14, D14, A16, B16, C16, A18, B18") = _
Range("A5, A7, D10, A12, A14, B14, D14, A16, B16, C16, A18, B18").Value
Sheets("layout-volume").Range("A5, D5, A8, A10, C10, A12, C14") = _
Range("A5, D5, A8, A10, C10, A12, C14").Value
Sheets("Munka1").Delete
ActiveWorkbook.Save
ActiveWindow.Close
End If
FN = Dir()
Loop Until FN = ""
Application.DisplayAlerts = True
End Sub -
-
Delila_1
veterán
válasz
adamssss
#22889
üzenetére
Jó lett volna, ha megírod, melyik verziót használod, mert eltér a feltételes formázás a régebbi és az újabb verziókban.
Vegyük, hogy a Terv az A, a Tényleges a B oszlop, címsorod van, és az utolsó kitöltött oszlopod az M. Kijelölöd az A2:M valahány sort. Eddig egyforma minden verzióban. Akkor is A-tól kezdve jelölsz, ha a Terv nem az A oszlopban van, csak akkor a hivatkozás változik a képletben.
2007-es verzió előtt Formátum | Feltételes formázás. 1. feltétel | A képlet értéke. Kapsz egy hosszú rovatot, ahova beírod: =$A2>$B2. Az egyenlőségjelet HA szóként kell értelmezni. A Formátum | Mintázatban kiválasztod a háttérszínt. Visszaértél a Formázási feltételekhez, ahol a Hozzáadás gombbal hasonló módon megadod a 2. feltételt, itt =$B>$A, másik szín.
Ügyelj a $ jelekre!
2007-től:
Kezdőlap | Stílusok | Feltételes formázás | Új szabály | A formázandó cellák kijelölése képlettel.
Az értékek formázása, ha ez a képlet igaz rovatba beírod a fenti első képletet, majd megadod a formátumot, OK. A 2. feltételt ugyanígy adhatod meg.A formátumot mindegyik verzióban pl. a formátumfestő ecsettel tudod másolni a többi sorra.
-
Delila_1
veterán
Fferi válaszán felbuzdulva a personalomba tettem egy rövid makrót, ami a szerkesztőlécet ki-bekapcsolja.
Ikont, és/vagy gyorsbillentyűt rendelhetsz hozzá. A 2003-as verzióban még saját rajzzal is el tudod látni az ikont.Sub Szerkesztolec()
If Application.DisplayFormulaBar = True Then
Application.DisplayFormulaBar = False
Else
Application.DisplayFormulaBar = True
End If
End SubA personal szóra rákeresve több hsz-t találsz, amik leírják, mit kell tenned.
-
![;]](http://cdn.rios.hu/dl/s/v1.gif)
Új hozzászólás Aktív témák
Hirdetés
- Eladó steam/ubisoft/EA/stb. kulcsok Bank/Revolut/Wise (EUR, USD, crypto OK)
- Antivírus szoftverek, VPN
- Microsoft licencek KIVÉTELES ÁRON AZONNAL - UTALÁSSAL IS AUTOMATIKUS KÉZBESÍTÉS - Windows és Office
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- ÁRGARANCIA!Épített KomPhone Ryzen 5 7600X 32/64GB RAM RX 9070 16GB GAMER PC termékbeszámítással
- BESZÁMÍTÁS! Asus ROG Flow Z13 + ROG XG RTX 3070 - i9 12900H 16GB DDR5 RAM 1TB SSD + RTX 3070 8GB WIN
- DDR3 BAZÁR! 8GB 16GB 1333MHz 1600MHz 2400MHz DDR3 memória garanciával hibátlan működéssel
- AKCIÓ! Microsoft XBOX Series S 512GB játékkonzol garanciával hibátlan működéssel
- Gyors, Precíz, Megbízható TELEFONSZERVIZ, amire számíthatsz! Akár 1 órán belül
Állásajánlatok
Cég: PC Trade Systems Kft.
Város: Szeged
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest