-
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
-
Delila_1
veterán
válasz
ALbeeeee
#7287
üzenetére
Tedd a 2-2 dolgot egy then, és egy else ágba. Egy ilyen nyúlfakrnyi programnál nem lehet észrevenni, de az IF-es sorok növelik a futási időt.
A kombipanelhez rendeld a makrót, ami egy közönséges Sub-bal kezdődik, és tartalmazza a két objektumod láthatóságát.
Hogy akarod átmásoltatni a textbox értékét, ha egyszerre sosem nem látható a textbox és a téglalap?
-
Delila_1
veterán
válasz
ALbeeeee
#7285
üzenetére
Private Sub Worksheet_Change(ByVal Target As Range)
If Sheets("Munka1").Range("F11") = 1 Then
Munka1.DrawingObjects("Lekerekített téglalap 10").Visible = True
Munka1.TextBox1.Visible = True
Else
Munka1.DrawingObjects("Lekerekített téglalap 10").Visible = False
Munka1.TextBox1.Visible = False
End If
End SubHonnan veszed a lenyílót, amivel az F11-be viszed be az értéket? A LinkedCell-be add meg az F11-et.
Nálam egyszerű adatérvényesítéssel működik. -
Delila_1
veterán
válasz
ALbeeeee
#7282
üzenetére
Igen.
Kimerítő válasz
Egy picit szépítettem a hosszabb makrón (Fire, utólagos engedelmeddel)
Sub Téglalap()
Sheets("Munka2").Activate
Cells(Sheets("Munka2").Rows.Count, "D").End(xlUp).Offset(1, 0).Select
If Munka1.TextBox1.Text <> "" Then
j = WorksheetFunction.CountIf(Range("D1:" & "D" & _
ActiveCell.Row), Munka1.TextBox1.Text)
If j = 0 Then
ActiveCell = Munka1.TextBox1.Text
Else
MsgBox ("A TextBox1 tartalma (" & Munka1.TextBox1.Text & _
") már szerepel a D" & " oszlopban")
End If
Else
MsgBox ("A TextBox1 üres!")
End If
Munka1.TextBox1.Text = ""
Sheets("Munka1").Select
End Sub -
Delila_1
veterán
válasz
ALbeeeee
#7279
üzenetére
A Munka1 laphoz két makrót kell illesztened – a VBE-ben bal oldalon a Munka1-en dupla klikk-re kapott üres lapra:
Private Sub Worksheet_Activate()
If Cells(11, 6) = 2 Then
TextBox1.Visible = True
Else
TextBox1.Visible = False
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$F$11" Then
If Target.Value = 2 Then
TextBox1.Visible = True
Else
TextBox1.Visible = False
End If
End If
End SubA Module1 laphoz:
Sub Lekerekítetttéglalap_9_Kattintáskor()
myCol = "D"
Sheets("Munka2").Activate
Cells(Sheets("Munka2").Rows.Count, myCol).End(xlUp).Offset(1, 0).Select
If Munka1.TextBox1.Text <> "" Then
j = WorksheetFunction.CountIf(Range(myCol & "1:" & myCol & ActiveCell.Row), Munka1.TextBox1.Text)
If j = 0 Then
ActiveCell = Munka1.TextBox1.Text
Else
MsgBox ("A TextBox1 tartalma már szerepel a " & myCol & " oszlopban")
End If
Else
MsgBox ("A TextBox1 üres!")
End If
Munka1.TextBox1.Text = ""
Sheets("Munka1").Select
End SubEzt a makrót kell hozzárendelned az alakzatodhoz.
-
#7280
Fire/SOUL/CD
félisten
ALbeeeee
#7279
-
#7270
Fire/SOUL/CD
félisten
ALbeeeee
#7267
válasz
ALbeeeee
#7267
üzenetére
Hali!
Csináld meg a Formot, amit Delila_1 itt feljebb bemutatott, aztán illeszd be ezt a kódot.
Private Sub CommandButton1_Click()
myCol = "D"
myColasInt = Asc(myCol) - Asc("@")
Sheets("Munka2").Activate
Cells(Sheets("Munka2").Rows.Count, myCol).End(xlUp).Offset(1, 0).Select
If TextBox1.Text <> "" Then
j = WorksheetFunction.CountIf(Range(myCol & "1:" & myCol & ActiveCell.Row), TextBox1.Text)
If j = 0 Then
'Ezt akkor, ha az adott oszlop végére kell beírni a Textbox1 tartalmát
'ActiveCell = TextBox1.Text
'Ezt meg akkor, ha nem a végére
j = ActiveCell.Row
Range(myCol & "1").Select
For i = 1 To j
If Cells(i, myColasInt) = "" Then
Cells(i, myColasInt) = TextBox1.Text
Exit For
End If
Next i
Else
MsgBox ("A Texbox1 tartalma már szerepel a " & myCol & " oszlopban")
End If
Else
MsgBox ("A Texbox1 üres!")
End If
Sheets("Munka1").Activate
End Sub
Private Sub UserForm_Activate()
If Sheets("Munka1").Range("F11") = 2 Then
TextBox1.Visible = True
Else
TextBox1.Visible = False
End If
End SubFire.
UI: Igen, valóban F11, nem F12...
-
#7258
Fire/SOUL/CD
félisten
ALbeeeee
#7255
válasz
ALbeeeee
#7255
üzenetére
Hali!
1. kérdésre
If Range("F12") = 2 Then
TextBox1.Visible = True
Else
TextBox1.Visible = False
End IfDelila_1
1. A kódod hol keresi meg, hogy már szerepelt-e a D oszlopban Textbox1 tartalma?
![;]](//cdn.rios.hu/dl/s/v1.gif)
2. Az első üres cella az kétértelmű, mert értelmezhető úgy is, hogy nem feltétlenül az utolsó cella+1 (pl D1 : D10 tartományban csak a D3 üres, ez esetben a D3-ba kell az adatot beírni, nem pedig a D11-be) De erről majd ALbeeeee nyilatkozik...Fire.
-
Delila_1
veterán
-
perfag
aktív tag
válasz
ALbeeeee
#6990
üzenetére
Chip Pearson szerint:
"The following formula can be used to count the number of times that the character or string of characters in cell B1 occurs in the string in cell A1. For example, if A1 contains the string abcXdXeXf, and cell B1 contains the character X, the formula will return 3, since there are 3 'X' characters in A1. This formula does not distinguish between upper and lower case.
=IF(LEN(B1)=0,0,(LEN(A1)-LEN(SUBSTITUTE(A1,B1,"")))/LEN(B1))"Ez magyar Excelben:
=HA(HOSSZ(B1)=0;0;(HOSSZ(A1)-HOSSZ(HELYETTE(A1;B1;"")))/HOSSZ(B1))
Azzal, hogy nálam a 2007-es igenis különbséget tett x és X között. Bár ez mellékes, úgyis a vesszőket akarod számolni. -
Delila_1
veterán
válasz
ALbeeeee
#6990
üzenetére
Szerintem 1-gyel több név van a cellában, mint vessző.
Józsi, Béla, Ancsa, Lujza -> 3 vessző, 4 név. Ha mégis azonos a nevek és a vesszők száma, a Vesszo=v+1 sorból töröld ki a +1-et.Írtam egy függvényt rá.
Function Vesszo(Cella As String) As Integer
Dim i As Integer, v As Integer
For i = 1 To Len(Cella)
If Mid(Cella, i, 1) = "," Then v = v + 1
Next
Vesszo = v + 1
End FunctionEzt bemásolod a fájlod VB szerkesztőjébe.
Alkalmazása: =Vesszo(A1) [ha a nevet tartalmazó cellád az A1]
Ugyanúgy másolható, mint a többi függvény. -
Delila_1
veterán
válasz
ALbeeeee
#5557
üzenetére
A két ellipszis gombként való alkalmazása:
Objektumon jobb klikk, makróhozzárendelés. Megjelenik a párbeszéd ablak, és felajánlja az EllipszisN_Kattintáskor nevű makrót. Rögzítés, és minden más nélkül rögzítés vége. Ugyanez a másik objektumnál is. A két "üres" makróba másold be a lenti kettőt. Az első megjeleníti a Téglalap 4-et, a másik elrejti. Ezekhez már kell az "ActiveSheet.", mert a makrók nem a laphoz vannak rendelve, mint az előző. Elérése: Alt+F11, a bal oldali listán kiválasztod a füzeted nevét, ott a Modules-t, és abban a ModuleN-ben találod meg.Sub Ellipszis1_Kattintáskor()
ActiveSheet.DrawingObjects("Téglalap 4").Visible = True
End Sub
Sub Ellipszis2_Kattintáskor()
ActiveSheet.DrawingObjects("Téglalap 4").Visible = False
End SubAz érvényesítés szövegei nálam egy fájlnál elmásztak, mindig más helyen jelentek meg, azért nem ajánlottam. Többet tettem egy lapra, és mindegyik ott jelent meg, ahova az utolsót helyeztem.
-
#5553
Fire/SOUL/CD
félisten
ALbeeeee
#5551
-
Delila_1
veterán
válasz
ALbeeeee
#5551
üzenetére
Ezt tudtommal csak makróval lehet megoldani. Rajzolsz egy téglalapot, rajta jobb klikk, Szöveg hozzáadása. Beírod a kommentet. A szerkesztőléc bal oldalán megnézed, milyen nevet rendelt hozzá az Excel (Téglalap, szóköz, és egy sorszám).
A lapfülön jobb klikk, kód megjelenítése. Megnyílik a VB szerkesztő. A jobb oldalon kapott üres lapra bemásolod:Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$2" Then ActiveSheet.DrawingObjects("Téglalap 5").Visible = True
If Target.Address = "$C$2" Then ActiveSheet.DrawingObjects("Téglalap 5").Visible = False
End SubEnnek hatására, ha a B2 cellára kattintasz, megjelenik a kommented ott, és akkora méretben, ahol és ahogy rajzoltad. A C2-re kattintva eltűnik (ezt be is írhatod a szövegbe, ha más is használja a fájlt).
A makróban a Téglalap 5 helyett 2 helyen írd be a saját objektumod nevét. Akár ellipszist is rajzolhatsz, csak a makróban a megfelelő nevet add meg. -
#5547
Fire/SOUL/CD
félisten
ALbeeeee
#5544
-
![;]](http://cdn.rios.hu/dl/s/v1.gif)
Új hozzászólás Aktív témák
Fferi50- Kerékpárosok, bringások ide!
- PlayStation 5
- Project Motor Racing-Straight4 Studios
- OLED monitor topic
- Xbox Series X|S
- A fociról könnyedén, egy baráti társaságban
- Elektromos autók - motorok
- Samsung Galaxy Buds3 Pro - szárat eresztettek a babok
- Mit tehetsz jogilag, ha átvertek, megkárosítottak a Hardveraprón?
- Mibe tegyem a megtakarításaimat?
- További aktív témák...
- Game Pass Ultimate előfizetések 1 - 36 hónapig azonnali kézbesítéssel a LEGOLCSÓBBAN! AKCIÓ!
- Fallout 4 Pip-Boy Edition eladó
- Vírusirtó, Antivirus, VPN kulcsok GARANCIÁVAL!
- Windows 10/11 Home/Pro , Office 2024 kulcsok
- Xbox / Microsoft Store feltöltőkártya kód (digitális, HU) több címlet, több db, azonnal, olcsón
- Apple iPhone 11 Pro 64GB, Kártyafüggetlen, 1 Év Garanciával
- Apple iPhone 14 Pro Max / 128GB / Kártyafüggetlen / 12Hó Garancia / Akku: 87%
- BESZÁMÍTÁS! ASRock B450M R5 3600 8GB DDR4 120GB SSD 1TB HDD GTX 1650 Super 4GB Zalman T3 Plus 400W
- Samsung Galaxy S26 Ultra Pitaka tok, üvegfólia
- -68%OFF HP Spectre x360 14 (14-ef2276ng) i7-1355U/16GB/1TBSSD/3K 3000X2000 Amoled
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest