-
IT café
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
-
#75376384
törölt tag
sziasztok
egy triviális kérdésem lenne. cellaformázás esetén melyik az a beállítás, hogy ha beírok egy cellába valamilyen képletet, majd annak eredménye mögé vagy elé karaktereket illesszen, de az egészet továbbra is számként kezelje.
példával szemléltetve, annyi lenne, hogy pár értékem mögé "m" kellene, illetve pár érték elé egy plusz-mínusz jel.köszi előre is.
-
Fferi50
őstag
válasz Delila_1 #23348 üzenetére
Szia!
Ezt kell a Thisworkbook kódlapjára beírni:
Public kilepo As Boolean
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
If kilepo Then Exit Sub
Application.ScreenUpdating = False
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(0, -1).Select
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Munka1.fmtcondis.Count > 0 Then
For Each fmt In Munka1.fmtcondis
fmt.Delete
Munka1.fmtcondis.Remove 1
Next
End If
If MsgBox("Valóban kilép?", vbQuestion + vbYesNo, "Bezárás") = vbNo Then
Application.ScreenUpdating = False
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(0, -1).Select
Application.ScreenUpdating = True
Cancel = True
Else
valasz = MsgBox("Menti a változásokat?", vbQuestion + vbYesNoCancel, "Bezárás")
If valasz = vbNo Then
ThisWorkbook.Saved = True
kilepo = True
ElseIf valasz = vbYes Then
kilepo = True
ThisWorkbook.Save
Else
Application.ScreenUpdating = False
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(0, -1).Select
Application.ScreenUpdating = True
Cancel = True
End If
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Munka1.fmtcondis.Count > 0 Then
For Each fmt In Munka1.fmtcondis
fmt.Delete
Munka1.fmtcondis.Remove 1
Next
End If
End Sub
Private Sub Workbook_Open()
Application.ScreenUpdating = False
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(0, -1).Select
Application.ScreenUpdating = True
End SubEzzel elérhető, hogy a "célkeresztet" nem menti le, de a fájl megnyitásakor első dolga, hogy létrehozza: ezért lép oda-vissza egyet az aktív munkalapon.
Mentés előtt eltünteti a célkeresztet, de ha csak mentés volt, utána vissza is hozza.
Kilépéskor végigjátssza a verziókat, ha mégsem lép ki, akkor marad a célkereszt.Üdv.
[ Szerkesztve ]
-
Fferi50
őstag
-
Fferi50
őstag
Szia!
A szövegből először oszlopokat csinálsz a "megtalált opcióval" mondjuk az A1-től kezdődően.
Azután kijelölöd a kivánt adatokat a sorban.
Másolás
Kijelölöd az A2 cellát.
Irányított beillesztés - transzponálás
Máris oszlopban sorakoznak a számaid.
Utána még nyomj egy ESC-t, hogy kilépj a másolás módból.Üdv.
-
slashing
senior tag
találtam a neten egy ilyet...
Sub test()
Dim e, s
With CreateObject("System.Collections.ArrayList")
For Each e In Range("a2", Range("a" & Rows.Count).End(xlUp)).Value
If Not IsEmpty(e) Then
For Each s In Split(e, ";")
.Add s
Next
End If
Next
.Sort
Range("b2").Resize(.Count).Value = _
Application.Transpose(.ToArray)
End With
End Suba pontos vesszőt írd át vesszőre a .Sort sort meg töröld hogy ne rendezze....
-
Fferi50
őstag
válasz Delila_1 #23348 üzenetére
Szia!
Sikerült még rövidítenem a Thisworkbook BeforeClose -on:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If MsgBox("Valóban kilép?", vbQuestion + vbYesNo, "Bezárás") = vbNo Then
Cancel = True
Else
valasz = MsgBox("Menti a változásokat?", vbQuestion + vbYesNoCancel, "Bezárás")
If valasz = vbCancel Then Cancel = True: Exit Sub
If Munka1.fmtcondis.Count > 0 Then
For Each fmt In Munka1.fmtcondis
fmt.Delete
Munka1.fmtcondis.Remove 1
Next
End If
If valasz = vbNo Then
ThisWorkbook.Saved = True
kilepo = True
Else
kilepo = True
ThisWorkbook.Save
End If
End If
End Sub -
nagyúr
Üdv. Kollégák szám típusú mezőre hogyan tudnék kiadni max limit-et, illetve ha belekattolok "megjegyzés" jelenjen meg(nem pontosan megjegyzés(széljegyzet tán?), ez vmi más kis panel, amibe írja mennyi az a limit)?
[ Szerkesztve ]
-
-
slashing
senior tag
Kellene nekem is egy kis macrós segítség csak részben tudom összeollózni a neten találtakból magamtól meg nem igen megy A követekző lenne a feladat:
- Az aktív munkalapon jelölje ki a D5 cellától kezdődően jobbra és lefele addig a cellákat amíg adatok vannak benne.
- Másolja új lapra rátok bízom hogy ez egy már meglévő munkalap vagy mindig újat csinál.
- Az új lapon miután beillesztette az adatokat minden második oszlop elé szúrjon be egy új oszlopot majd egy input mező jöjjön fel és amit beleír az ember azzal töltse fel az új oszlopokat addig amíg adatok vannak, 99,9% hogy mindig minden oszlop ugyan annyi sorban fog adatot tartalmazni mint amennyi az első oszlopban van.
- Ha ez megvan szúrjon be még két üres sort az A oszlop elé, még két input kérelem az első egy dátumkérés a második egy szöveges kérés, itt már elég csak az új A1-be a dátumo és B1-be a szöveget...
- Jelölje ki ezt az egész tartomány és másolja a vágólapra. -
-
Delila_1
Topikgazda
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 SubProgramozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
slashing
senior tag
válasz slashing #23360 üzenetére
Hát eddig jutottam:
Sub Makró5()
Dim c As Long, myvalue As Variant, lastrow As Long
Range("D5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Munka1").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
c = Range("XFD1").End(xlToLeft).Column
For c = c To 2 Step -1
Cells(1, c).EntireColumn.Insert
Next c
myvalue = InputBox("add meg a szöveget")
Range("B1").Value = myvalue
lastrow = Worksheets("munka1").Range("A1").End(xlDown).Row
With Worksheets("munka1").Range("B1")
.AutoFill Destination:=Range("B1:B" & lastrow&)
End With
Columns("A:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
myvalue = InputBox("add meg a dátumot")
Range("A1").Value = myvalue
Range("B1").Select
myvalue = InputBox("add meg a szöveget")
Range("B1").Value = myvalue
End Subközel sem tökéletes pl. a dátum helyére bármit beírhatnék de ez legyen a legkevesebb. Annyi kéne még hogy az első szöveg bekérés után kitölti az oszlopot a megadott szöveggel de ezt tovább kéne vinni az utolsó oszlopig is.
(#23362) Delila_1
Máris nézem köszönöm
[ Szerkesztve ]
-
m.zmrzlina
senior tag
válasz slashing #23360 üzenetére
Nekem ezt sikerült kiötleni:
Sub makro_1()
elsouzenet = InputBox("blablabla1")
masodikuzenet = InputBox("blablabla2")
datum = InputBox("datum")
Range("D5").Select
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.End(xlDown).Row, ActiveCell.End(xlToRight).Column)).Select
Selection.Copy
Sheets.Add
ActiveSheet.Paste
hanysor = Selection.Rows.Count
hanyoszlop = Selection.Columns.Count
For i = hanyoszlop To 1 Step -1
Range(Cells(1, i), Cells(hanysor, i)).Select
Selection.Insert Shift:=xlToRight
Selection.Value = elsouzenet
Next
Range("A:B").Select
Selection.Insert Shift:=xlToRight
Range("B1").Value = masodikuzenet
Range("A1").Value = datum
Range(Cells(1, 1), Cells(hanysor, ActiveCell.End(xlToRight).Column)).Select
Selection.Copy
End Sub -
slashing
senior tag
Baromi jók vagytok a bőség zavara Köszönöm. és mindegyikből tanultam valami újat, látszik ahány ember annyi kód ugyan arra. Egy valami hibázik csak, hogy az utolsó értéket tartalmazó oszlop után is ki kell még iratni az első input szöveget.
-
slashing
senior tag
válasz m.zmrzlina #23366 üzenetére
Köszi és neked is Delila_1 mindkét verzió nagyon jó és hasznos volt, pont úgy megy ahogy akartam
-
Fferi50
őstag
válasz Delila_1 #23370 üzenetére
Szia!
Itt egy példa:
Ez a munka1 munkalapon működik. (Munka2-t felejtsd el, csak nem töröltem ki.)
Ha közben makrót írsz, akkor elképzelhető a hibára futás. Viszont ezt el tudod kerülni azzal, hogy a munka1-en levő, a célkereszthez tartozó feltételes formázásokat a feltételes formázás kezelővel kitörlöd, a többit viszont hagyd változatlanul.Utána ha lépsz egyet, megjön a célkereszt ismét.
Üdv.
[ Szerkesztve ]
-
Imy
veterán
Hogyan tudom beírni a cellába pl hogy 30cm? Hogy tudjon vele számolni, maradjon szám.
-
m.zmrzlina
senior tag
-
Imy
veterán
válasz m.zmrzlina #23376 üzenetére
Köszönöm!!!
-
slashing
senior tag
Most már csak a user errorokat próbálom kiküszöbölni. Érdekelne hogy mi a legegyszerűbb megoldás arra hogy a Név és WO kérésre ha valamiért Mégsét nyom vagy nem ír be semmi és úgy okézza le akkor ne lépjen tovább a program hanem mindenképpen be kelljen írni valamit?
A dátumot megoldottam egy neten talált példa alapján de kicsit hosszasnak érzem a kódot nem szeretném mindegyikre így végigvezetni.Ötletek?
Így indul a kód:
Dim lastRow As Long, asn As String, DatumString As String, datum As Date
Dim valid As Boolean: valid = True
asn = ActiveSheet.Name
'adatok bekérése
nev = InputBox("A mérést végző személy Teljes neve:")
wo = InputBox("A méréshez tartozó WO szám Bxxxxxx/xx:")
Do
DatumString = Application.InputBox("A mérés dátuma ÉÉÉÉ/HH/NN: ")
If IsDate(DatumString) Then
datum = DateValue(DatumString)
valid = True
Else
MsgBox "Érvénytelen dátum"
valid = False
End If
Loop Until valid = True -
slashing
senior tag
Jah meg még egy kérdés ki lehet azt játszani valahogy ha valamit vágólapra másoltatok de ezután lefut egy selection.clearcontents de dobja el a vágólap tartalmát?
(#23380) Mittu88 köszi mindjárt ki is próbálom
[ Szerkesztve ]
-
Mittu88
senior tag
-
m.zmrzlina
senior tag
válasz slashing #23381 üzenetére
Nekem is volt (van) ilyen problémám. Sokat gugliztam meg kérdeztem (itt is) a végén arra jutottam, hogy nem hagyom a vágólapra a tartalmat. Kiírtam (akár rejtett) munkalapra aztán ha kellett visszaolvastam. Lehet hogy nem a legprofibb megoldás de működik.
[ Szerkesztve ]
-
m.zmrzlina
senior tag
válasz m.zmrzlina #23387 üzenetére
Talán egy fokkal jobb, ha kiírod tömbbe. Onnantól fogva van egy változód amit kedved szerint módosíthatsz aztán a végén visszaírod a munkalapra.
-
slashing
senior tag
válasz m.zmrzlina #23387 üzenetére
Hát én is kb. erre jutottam: miután lefutott a kódom nem térek vissza arra a lapra ahonnan másolni akarok hanem előbb a törlendő lapra ugrok és törlök majd visszaugrok a másolandó adatokat tartalmazó lapra ott másolok és újra visszaugrok arra a lapra hol előtte kitöröltem. szóval csináltam egy oda vissza oda bakugrást
-
bteebi
veterán
válasz slashing #23384 üzenetére
Azt amúgy hogy lehetne megcsinálni, hogy csak szóköz(öke)t ne adhasson meg névnek? Mert ez
Loop Until nev <> "" And nev <> " " Or nev = False
csak egy karakternyi szóközig működne, n db esetén már nem.Némi keresgélés után sikerült megoldanom, de az azért érdekelne, hogy meg lehetne-e szebben is írni (egyszerűbben minden bizonnyal nem):
Do
nev = InputBox("A mérést végző személy Teljes neve:")
ujnev = WorksheetFunction.Substitute(nev, " ", "")
Loop Until ujnev <> "" Or nev = FalseCancel all my meetings. Someone is wrong on the Internet.
-
slashing
senior tag
Hát ilyen variációra nem is gondoltam de azthiszem belerakom úgy hogy minimum 5 karakter legyen a hossza és akkor már rövidíteni sem tudja a nevét. Persze a 6 szóközt így is elengedi de mennyi erre az esély hogy kipróbálja?
-
m.zmrzlina
senior tag
válasz slashing #23393 üzenetére
Én ezt egyszer úgy oldottam meg, hogy az inputboxban megadtam a formáját a neveknek amit elfogad a makró.
technikus = UCase(InputBox("Add meg a technikus nevét!" & Chr(10) "TUDOR VIDOR SZENDE SZUNDI MORGÓ HAPCI KUKA MIND"))
If technikus <> "MIND" Then
If Application.WorksheetFunction.CountIf(Worksheets("PrnWinExcel").range("B:B"), technikus) = 0 Then
MsgBox "Nincs ilyen technikus."
Exit Sub
ElseIf technikus = "" Then
Exit Sub
End If
End IfPersze ez csak akkor működik ha minden elfogadható input ismert a programozás idején, nem bővül vagy egészül ki esetleges elemekkel a Worksheets("PrnWinExcel").range("B:B") tartomány vagy van lehetőség a folyamatos frissítésére.
[ Szerkesztve ]
-
slashing
senior tag
Huh vannak ám variációk én meg akkor mondok egy harmadikat.
Mi lenne ha reguláris kifejezéssel írnánk le hogy mi az amit elfogadhat?
Most fejből meg nem írom mi ennek a regexp kódja de mittudom én [a-zA-Z] szókóz [a-zA-Z] lenne
csak gőzöm sincs hogy kezeli a VBA a regexp kódot
amúgy a folyamatos frissítésre lenne lehetőségem csak ***** mód lusta vagyok és nincs kedvem hozzá
[ Szerkesztve ]
-
slashing
senior tag
válasz Mittu88 #23397 üzenetére
a legegyszerűbb ha úgy mondom mint amikor keresel valamilyen fájlt a számítógépen és azt írod hogy:
*kutya*.* így megkeresel minden olyan fájlt amiben a kutya szó szerepel bármilyen kiterjesztéssel, ez is kvázi egy regex kifejezés...
szóval ilyen kifejezéssek leírhatod hogy mit szeretnél kerestetni karaktereket számokat azoknak a hosszát stb...
Mindent az ég egy adta világon le lehet írni velük de mocskos bonyolult tud lenni, szerencsére nem sok közöm volt eddig hozzá.
-
Delila_1
Topikgazda
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.
[ Szerkesztve ]
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
Új hozzászólás Aktív témák
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- AKCIÓ! - STEAM kulcsok /Anuchard, Aragami, Children of Morta, stb. - 2024.04.17.
- Game Pass Ultimate előfizetések 1 - 25 hónapig azonnali kézbesítéssel a LEGOLCSÓBBAN!
- Vírusirtó, Antivirus VPN kulcsok
- World of Warcraft Shadowlands Collectors edition EU EN