- D1Rect: Nagy "hülyétkapokazapróktól" topik
- zebra_hun: Hűthető e kulturáltan a Raptor Lake léghűtővel a kánikulában?
- bitpork: Augusztus 2- szombat jelen állás szerint.
- Luck Dragon: Asszociációs játék. :)
- eBay-es kütyük kis pénzért
- sziku69: Fűzzük össze a szavakat :)
- Geri Bátyó: B550 szűk keresztmetszet, de mi és miért?
- Yutani: Yutani Retró Hangkártyái: AdMOS AdWave 32
- user2: Kia Ceed Gold 160 1.5 T-GDI MY2024
- Kempingezés és sátrazás
-
LOGOUT
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
-
Mutt
senior tag
Szia,
Addinként tesztelted vagy egy sima fájlba tetted még a kódot?
Az űrlap új fájlt nyit, esetleg bezárja az aktuálisat?A kód a fájl bezárásakor leszedi az új menűt (DeleteControls program). Ami addin esetén nem okoz gondot, mivel az az összes Excel ablak bezárásakor fog csak lefutni.
üdv
-
karlkani
aktív tag
Jelszavazással az a gond, hogy program sem kell, hogy törölni lehessen őket. A foci VB alatt letöltöttem egy "minta" táblázatot, néhány dolgot módosítani szerettem volna rajta, de jelszóval védett volt. A megoldást se perc alatt kiguliztam. Addig volt jelszóval védve a munkafüzet, nekem meg lett egy jó kis "menetrendem".
-
Mutt
senior tag
Szia,
A ribbon módosítást nem vágom, de nekem az alábbi kód Excel 2010 óta jól megy saját készítésű addin-ban:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' START ThisWorkbook Code Module
' Created By Chip Pearson, chip@cpearson.com
' Sample code for Creating An Add-In at http://www.cpearson.com/Excel/CreateAddIn.aspx
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Private Const C_TAG = "Makro" ' C_TAG should be a string unique to this add-in.
Private Const C_TOOLS_MENU_ID As Long = 30007&
Private Sub Workbook_Open()
'''''''''''''''''''''''''''''''''''''''''''''''
' Workbook_Open
' Create a submenu on the Tools menu. The
' submenu has two controls on it.
'''''''''''''''''''''''''''''''''''''''''''''''
Dim ToolsMenu As Office.CommandBarControl
Dim ToolsMenuItem As Office.CommandBarControl
Dim ToolsMenuControl As Office.CommandBarControl
'''''''''''''''''''''''''''''''''''''''''''''''
' First delete any of our controls that
' may not have been properly deleted previously.
'''''''''''''''''''''''''''''''''''''''''''''''
DeleteControls
''''''''''''''''''''''''''''''''''''''''''''''
' Get a reference to the Tools menu.
''''''''''''''''''''''''''''''''''''''''''''''
Set ToolsMenu = Application.CommandBars.FindControl(ID:=C_TOOLS_MENU_ID)
If ToolsMenu Is Nothing Then
MsgBox "Unable to access Tools menu.", vbOKOnly
Exit Sub
End If
''''''''''''''''''''''''''''''''''''''''''''''
' Create a item on the Tools menu.
''''''''''''''''''''''''''''''''''''''''''''''
' Set ToolsMenuItem = ToolsMenu.Controls.Add(Type:=msoControlPopup, temporary:=True)
' If ToolsMenuItem Is Nothing Then
' MsgBox "Unable to add item to the Tools menu.", vbOKOnly
' Exit Sub
' End If
'
' With ToolsMenuItem
' .Caption = "&Menu Item"
' .BeginGroup = True
' .Tag = C_TAG
' End With
''''''''''''''''''''''''''''''''''''''''''''''
' Create the first control on the new item
' in the Tools menu.
''''''''''''''''''''''''''''''''''''''''''''''
' Set ToolsMenuControl = ToolsMenuItem.Controls.Add(Type:=msoControlButton, temporary:=True)
Set ToolsMenuControl = ToolsMenu.Controls.Add(Type:=msoControlButton, temporary:=True)
If ToolsMenuControl Is Nothing Then
MsgBox "Unable to add item to Tools menu item.", vbOKOnly
Exit Sub
End If
With ToolsMenuControl
''''''''''''''''''''''''''''''''''''
' Set the display caption and the
' procedure to run when clicked.
''''''''''''''''''''''''''''''''''''
.Caption = "Ékezetek" 'idejön a saját elnevezésed
.OnAction = "'" & ThisWorkbook.Name & "'!Ekezetek" 'ez pedig a saját kódod
.Tag = C_TAG
End With
''''''''''''''''''''''''''''''''''''''''''''''
' Create another control on the new item
' in the Tools menu.
''''''''''''''''''''''''''''''''''''''''''''''
Set ToolsMenuControl = ToolsMenu.Controls.Add(Type:=msoControlButton, temporary:=True)
If ToolsMenuControl Is Nothing Then
MsgBox "Unable to add item to Tools menu item.", vbOKOnly
Exit Sub
End If
With ToolsMenuControl
''''''''''''''''''''''''''''''''''''
' Set the display caption and the
' procedure to run when clicked.
''''''''''''''''''''''''''''''''''''
.Caption = "SQL/BO Converter"
.OnAction = "'" & ThisWorkbook.Name & "'!Converter"
.Tag = C_TAG
End With
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Workbook_BeforeClose
' Before closing the add-in, clean up our controls.
''''''''''''''''''''''''''''''''''''''''''''''''''''
DeleteControls
End Sub
Private Sub DeleteControls()
''''''''''''''''''''''''''''''''''''
' Delete controls whose Tag is
' equal to C_TAG.
''''''''''''''''''''''''''''''''''''
Dim Ctrl As Office.CommandBarControl
On Error Resume Next
Set Ctrl = Application.CommandBars.FindControl(Tag:=C_TAG)
Do Until Ctrl Is Nothing
Ctrl.Delete
Set Ctrl = Application.CommandBars.FindControl(Tag:=C_TAG)
Loop
End Subüdv
-
Fferi50
Topikgazda
Szia!
A következőt javaslom: a listbox listáját átalakítjuk szöveggé és ebben keressük az adott nevet.
Dim szuro as string ' ez természetesen csak egyszer kell, valahol máshol előtte is lehet.
szuro=Join(Application.Transpose(ListBox2.List), ";")
If szuro Like "*" & Range("B" & i) & "*" Or szuro Like "*" & Range("C" & i) & "*" Then
Rows(i).EntireRow.Delete Shift:=xlUpÜdv.
-
Delila_1
veterán
A J1:J6 tartományba írtam be a keresendő neveket. Az If WF kezdetű sorban ezt írd át (2 helyen) a saját neveidet tartalmazó területre.
Sub torlesek()
Dim LR As Long, i As Long, WF As WorksheetFunction
Application.ScreenUpdating = False
Set WF = Application.WorksheetFunction
LR = Cells(Rows.Count, 2).End(xlUp).Row
For i = LR To 2 Step -1
If WF.CountIf(Range("J1:J6"), Range("B" & i)) + WF.CountIf(Range("J1:J6"), Range("C" & i)) = 0 Then
Rows(i).EntireRow.Delete Shift:=xlUp
End If
Next i
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
Sub torlesek()
Dim LR As Long, i As Long
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 2).End(xlUp).Row
For i = LR To 2 Step -1
If Range("B" & i) <> "Gipsz Jakab" And Range("C" & i) <> "Gipsz Jakab" And _
Range("B" & i) <> "Rezső Dezső" And Range("C" & i) <> "Rezső Dezső" Then
Rows(i).EntireRow.Delete Shift:=xlUp
End If
Next i
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
Sub Szures_Torles()
Dim usor As Long
'J oszlop szűrése
usor = Range("B" & Rows.Count).End(xlUp).Row '***********
ActiveSheet.Range("$A$1:$K$" & usor).AutoFilter Field:=10, Criteria1:=Array( _
"Befejezett", "Lezárt", "Törölt", "Várakozik"), Operator:=xlFilterValues
Range("A1").CurrentRegion.Offset(1).Delete Shift:=xlUp 'törlés
ActiveSheet.Range("$A$1:$K$" & usor).AutoFilter Field:=10 'szűrő:mind
'B oszlop szűrése
usor = Range("B" & Rows.Count).End(xlUp).Row '***********
ActiveSheet.Range("$A$1:$K$" & usor).AutoFilter Field:=2, Criteria1:=Array("=/=" _
, "A", "B", "C", "D", "E"), Operator:=xlFilterValues
Range("A1").CurrentRegion.Offset(1).Delete Shift:=xlUp 'törlés
ActiveSheet.Range("$A$1:$K$" & usor).AutoFilter Field:=2 'szűrő:mind
End SubAz usor változót olyan oszlopban állítsd be, ahol biztosan minden sorban van adat.
Az A1:K... helyére a szűréshez a saját tartományodat add meg. -
Fferi50
Topikgazda
-
Fferi50
Topikgazda
Szia!
A Weeknaming = Format(Date, "ww") eredménye egy kétjegyű szám.
"ActiveSheet.Name = "Valami_A_" & Weeknaming" a neve pl. Valami_A_46 lenne,
csak azt törli ki ahol a WS neve Valami_A_Week 46 volt pl, a többit nem, mikor és hol kerül bele a munkalap nevébe a Week?
Mert nyilván azt a munkalapot aminek nem egyezik a neve a "Valami_A_" & Format(Date, "ww") eredményével (lásd fentebb), ki fogja törölni.
A másik probléma:
Egy törlés után emiatt a sor miatt:
Worksheets(i).Delete
Exit For
azonnal kilép a ciklusból.Ha azt szeretnéd, hogy végigmenjen minden munkalapon, akkor ezt a sort töröld ki.
Üdv.
-
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).
-
Fferi50
Topikgazda
Szia!
Ha a sorok száma alapján szeretnéd dinamizálni, akkor:
For each sor in Sheets("Sheet1").UsedRange.Rows
célmunkalap létrehozása/kijelölése
ide jönnek a másolási műveletek
nem ártana ellenőrizni, hogy nincs-e esetleg üres sor benne, ha van, azt nyilván ki kell hagyni a másolásból.
NextÜdv.
-
Fferi50
Topikgazda
Szia!
Ha mindig ugyanoda kell másolni, akkor a makróba beírod egymás után:
Sheets("Sheet2").Range("B3").value=Sheets("Sheet1").Range("A2").value
Sheets("Sheet3").Range("B3").value=Sheets("Sheet1").Range("A3").value
Sheets("Sheet4").Range("B3").value=Sheets("Sheet1").Range("A4").value
és így tovább, minden egyes cellára.
Ha van valami szabályszerűség a másolásban, akkor ciklusba is szervezhető.(Ha nem csak az értékeket, hanem a formát is szeretnéd átvinni, akkor a fenti sorok helyett a copy metódust használhatod:
Sheets("Sheet1").Range("A2").Copy destination:=Sheets("Sheet2").Range("B3")
Sheets("Sheet1").Range("A3").Copy destination:=Sheets("Sheet3").Range("B3")
Sheets("Sheet1").Range("A4").Copy destination:=Sheets("Sheet4").Range("B3")
a másolásra.)Ha változó a másolás helye, akkor használhatod az Applicaction.inputbox metódust a cél cella bekéréséhez, ahol megadhatod, hogy milyen típusu legyen az input (8-as tipus a cella referencia). Így minden kérdéses cellánál megkérdezheted, most hova legyen másolva.
Az inputbox értékét egy változóba kérheted be:
Set myCell = Application.InputBox( prompt:="Select a cell", Type:=8)
majd ezt a változót használod célként.
Ebben az esetben az inputboxban egérrel kijelölheted melyik munkalap melyik cellájába kívánod a másolást.
Utána:
Sheets("Sheet1").Range("A4").Copy destination:=myCellRemélem, sikerülni fog valamelyik módszerrel megoldani a problémát.
Üdv.
-
Mutt
senior tag
Hello,
Egy olyan fuggvenyre lenne szuksegem, amivel az excel kepes eldonteni, hogy az 1 flottahoz tartozo kocsik kozul melyiknek a legmagasabb a rendszama.
Ha legalább Excel 2007-et használsz akkor az ÖSSZESÍT függvénnyel megoldható a legnagyobb rendszám keresése (A oszlop flotta, B rendszám, C-E oszlopok dátumok; 5000 sorig múködnek a képletek):
=ÖSSZESÍT(14;6;$B$2:$B$5000/($A$2:$A$5000=A2);1)Bármelyik Excel verzióban pedig az alábbi tömbképlet működik:
{=MAX(HA($A$2:$A$5000=A2;$B$2:$B$5000;))}A fenti képletek vmelyikét választva a calculated cellád képlete:
=HA(csodakeplet=B2;E2-D2;E2-C2)Ha a rendszámod alphanumerikus, akkor ezt tudom javasolni:
=HA(SZORZATÖSSZEG(($A$2:$A$5000=A2)*($B$2:$B$5000>B2))=0;E2-D2;E2-C2)üdv
-
Mutt
senior tag
Hello,
1. A B-oszlopban a dátum van vagy "XYZ"?
Az IF részben egyszer szöveget, keresel másszor dátumot.
2. A Format-os rész Datediff függvénnyel helyettesítendő.
3. Now helyett Date adja meg az aktuális dátumot.
4. Hátulról kell kezdeni a tőrlést.
5. Select-et érdemes mellőzni.Itt az én változatom (A-oszlopban dátum, B-ben szöveg):
If Menu.CheckBoxDateRangeFilter.Value = True Then
lastrow = Cells.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Do
If (Cells(lastrow, "B").Value <> "" And Cells(lastrow, "B").Value <> "XYZ") _
Or DateDiff("d", Date, Cells(lastrow, "A").Value) > Menu.TextBoxDaysAfter.Value Then
Rows(lastrow).Delete
End If
lastrow = lastrow - 1
Loop Until lastrow = 1
End IfAmi nem volt tiszta, hogy igazából mely sorokat kell törölni, a fenti kód azokat tőrli ahol
- van szöveg a B-ben és az nem XYZ (üres szöveges sorokat meghagyja)
- és ahol a dátum kívül van a megadott napokon.üdv.
-
-
Delila_1
veterán
-
Delila_1
veterán
Be van kapcsolva az Excelben az Analysis ToolPak, és az Analysis ToolPak - VBA? Lehet, hogy ezeket hiányolja. Eszközök | Bővítménykezelő menüpontban kapcsolhatod be.
Mivel láttam, hogy xls a kiterjesztés, 2003-as verzióban írtam a makrót, a bővítmények bekapcsolása után működnie kell.
-
Delila_1
veterán
Felvettem 2 változót. Az egyik a WS, ami Worksheet típusú, és a test.xls INT nevű lapját adtam meg értékének. A másik, WF, WorksheetFunction típusú. Ezt azért vettem fel, hogy a VLookup-ot tartalmazó sor könnyebben olvasható legyen.
Ha jól értettem, az indító füzet aktuális lapján az AB oszlopban lévő adatot keresed a test.xls INT lapjának A oszlopában, és a találat sorában az E oszlop tartalmát íratod az indító füzet T oszlopába.
Betettem a Vlookup sor elé egy hibaelhárítást arra az esetre, ha a keresett érték nem szerepelne a másik füzetben (On Error Resume Next).Sub Keres()
Dim sor As Long, usor As Long, WS As Worksheet, WF As WorksheetFunction
Set WS = Workbooks("test.xls").Worksheets("INT")
Set WF = Application.WorksheetFunction
usor = Range("AB" & Rows.Count).End(xlUp).Row
For sor = 2 To usor
If Cells(sor, "AB") > "" Then
On Error Resume Next
Cells(sor, "T") = WF.VLookup(Cells(sor, "AB"), WS.Range("A:P"), 5, 0)
End If
Next
End Sub -
-
1. Ha az a korábbi kód egy valós kód volt(és nem csak valamit betettél példának), akkor az a kód minden esetben az épp aktív munkalapon dolgozik, ergo mindegy hány darab és nevű munkalap van a munkafüzetben, mindig azon végzi el a módosításokat/feladatát, ami épp ki van jelölve, azaz aktív.
2. Az is egyértelműen leírtad, hogy az INT nevű munkalap minden esetben biztosan létezikEbből kiindulva ennyi az egész ("if munkalap neve = INT, lefut a makró, else nem fut le" - olyan nincs, hogy else nem fut le)
Private Sub MyMacro()
Dim lngLastRow
If ActiveSheet.Name = "INT" Then
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Columns("X:X").Select
Selection.Insert Shift:=xlToRight
Range("X1").Select
ActiveCell.FormulaR1C1 = "common_id"
Range("X2").Select
.
.
.
.
End If
End Sub -
-
Mutt
senior tag
Hello,
A létező xls-ben van-e már workbook open event?
Ha tőled függetlenül már van, akkor meg van az indok hogy miért hasal el.
Ha azt nem tudod/mered változtatni, akkor Auto_Open névvel kell egy module-ba a kódódat beszúrni.'új module beszúrása
Set VBComp = VBProj.VBComponents.Add(vbext_ct_StdModule)
VBComp.Name = "NewModule"
Set CodeMod = VBComp.CodeModule
'Auto_Open sub létrehozása
With CodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, "Sub Auto_Open()"
LineNum = LineNum + 1
.InsertLines LineNum, Code3
LineNum = LineNum + 1
.InsertLines LineNum, "End Sub"
End WithEsetleg az Auto_Close sub-ba pedig tehetsz egy olyat, hogy az Auto_Open-t törölje ha az már lefutott.
üdv.
-
Mutt
senior tag
Hali,
Ugyanarra jutottunk.
Az egyetlen gondom az, hogy a sub nem fut le automatikusan...
Mivel a Sheet1 Change eseményébe szúrod be ezért nem fut le, Workbook Open esemény kell, de meg kell oldanod hogy ne minden megnyitáskor, hanem csak változáskor fusson le.
LineNum = .CreateEventProc("Open", "Workbook")
Esetleg csinálhatod azt hogy
If Thisworkbook.Sheets("Sheet1").Range("A1") = "" Then
<ide az eredeti kód>
Thisworkbook.Sheets("Sheet1").Range("A1") = 1
End ifüdv.
-
Mutt
senior tag
Hello,
A hibát a
LineNum2 = .VBE.MainWindow.Visible = False sor okozza.
Mivel ez egy parancs a VBA editornak ezért csak így lesz jó:Application.VBE.MainWindow.Visible = False
Nekem így már lefut .xls-en is, látszólag .xlsx-en is megcsinálja, de mivel az makrómentes ezért mentéskor eldobja.
üdv.
-
lapa
veterán
-
lapa
veterán
ez micsoda?
LineNum2 = LineNum2 + 1
amúgy ettől függetlenül elég csúnya a sok select meg activecell meg ilyenek. valami ilyesmi is működne szerintem:
Dim lngLastRow
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Columns("X").Insert Shift:=xlToRight
range("X1").value = "common_id"Range("X2").Select
End Sub -
Mutt
senior tag
Hello,
...megkrealni a pivot tablat es ujranevezni az aktiv tabot, ami mar ugye letezik
Mielőtt futtatnád a makrót nézd meg, hogy van-e már Pivot a lapon.
If ThisWorkbook.Sheets("munkalap neve").PivotTables.Count = 0 Then
'ide jön az eredeti makró
End Ifvagy ahogy m.zmrzlina írta ellenőrízheted a munkalapok nevét is.
üdv.
-
Excelbarat
tag
Jól sejted csak a forrást kell átírnod így:
így kezdődjön:
Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ujforras = Sheets("Munka1").[A6].CurrentRegion.Address(ReferenceStyle:=xlR1C1)Majd a forrásnál így hivatkozz:
SourceData:= "Munka1!" & ujforrasA makró végére pedig be kell írni ezt:
Sheets("Munka4").PivotTables(1).RefreshTable -
Delila_1
veterán
2003-as verzióban a táblázatodban állva az Adatok | Űrlap menüpont segítségével azonnal megkapod ezt az űrlapot.
2007-ben kitehetsz egy ikont a gyorselérési eszköztárra. Az eszköztár végén található legördülővel behozod a További parancsokat | Minden parancs | Űrlap. Ezt az ikont használd.
-
-
Delila_1
veterán
"nem a pivot része, csak a pivotnak megfelelő sorba mellév an írva egy megjegyzés"
Akkor más a helyzet. A kimutatásokat másold egy lapra egymás alá, értékként beillesztve, mert a pivotokból nem engedi az Excel a sortörlést. Mivel nem írtad, melyik oszlopokban vannak a billentyűzetről – vagy érvényesítésből – bevitt megjegyzések, önhatalmúlag a H és I oszlopokba tettem (8. és 9. oszlop). Ezeket írd át a makróban a megfelelőkre.
Sub DelRow()
Dim sor As Integer, usor As Integer
usor = Range("A50000").End(xlUp).Row
For sor = usor To 2 Step -1
If Cells(sor, 8) = "" And Cells(sor, 9) = "" Then Rows(sor).EntireRow.Delete
Next
End Sub -
Delila_1
veterán
Ez a makró az A oszlopban A1-től figyeli, van-e megjegyzés. Ha nincs, törli a sort.
Sub DelRow()
Dim sor As Integer
sor = 1
Do While Cells(sor, 1) <> ""
If Range(Cells(sor, 1).Address).Comment Is Nothing Then
Rows(sor).EntireRow.Delete
sor = sor - 1
End If
sor = sor + 1
Loop
End SubAz A helyett 2 helyen a Cells(sor,1)-ben írd át az 1-et az oszlopod sorszámára. Ha nem az első sortól akarod a vizsgálatot végrehajtani, a sor=1-et írd át.
A makró feltételezi, hogy a kérdéses oszlop minden cellájában van valamilyen adat, ott is, ahol nincs megjegyzés. -
Kobe
veterán
Új hozzászólás Aktív témák
Hirdetés
- LG 40WP95XP-W - 40" NANO IPS - 5120x2160 5K - 72Hz 5ms - TB 4.0 - HDR - AMD FreeSync
- ÁRGARANCIA!Épített KomPhone Ryzen 5 4500 16/32/64GB RAM RTX 3050 6GB GAMER PC termékbeszámítással
- Csere-Beszámítás! MSI Gaming X RTX 4060Ti 16GB GDRR6 Videokártya!
- Gamer laptop felvásárlás Magas áron, gyorsan és egyszerűen!
- ÁRGARANCIA!Épített KomPhone Ryzen 5 7600X 16/32/64GB RAM RX 7700XT 12GB GAMER PC termékbeszámítással
Állásajánlatok
Cég: PC Trade Systems Kft.
Város: Szeged
Cég: PC Trade Systems Kft.
Város: Szeged