Hirdetés
- sziku69: Fűzzük össze a szavakat :)
- GoodSpeed: Márkaváltás sok-sok év után
- sziku69: Szólánc.
- Viber: ingyen telefonálás a mobilodon
- Luck Dragon: Asszociációs játék. :)
- GoodSpeed: 3I/Atlas: Üstökös vagy idegen civilizáció űrhajója?
- MaxxDamage: (TongFang) Medion Erazer Beast 16 X1 benchmark
- Sub-ZeRo: Euro Truck Simulator 2 & American Truck Simulator 1 (esetleg 2 majd, ha lesz) :)
- f(x)=exp(x): A laposföld elmebaj: Vissza a jövőbe!
- bb0t: Ikea PAX gardrób és a pokol logisztikája
-
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
-
Delila_1
veterán
válasz
logitechh
#42365
üzenetére
Az eredeti füzetek nevét beírod a Célfüzet.xlsm Céllap T oszlopába T1-től T15-ig, kiterjesztéssel együtt. Ebbe a füzetbe másold be modulba a Beilleszt makrót. Tehetsz ki hozzá egy gombot.
A makró abban a sorrendben, ahogy a T oszlopba beírtad a neveket, megnyitja az eredeti fájlokat, majd bemásolja belőlük a Célfüzet megfelelő helyére az A1:M12 tartományt. A megnyitott füzeteket mentés nélkül bezárja.Sub Beilleszt()
Dim usor As Integer, fuzet As Integer, utvonal As String, FN As String
utvonal = "F:\Eadat\Excel fórumok\PH\" 'Ezt írd át!
ActiveSheet.Protect Password:="Jelszo01", UserInterfaceOnly:=True
For fuzet = 1 To 15
FN = Cells(fuzet, "T")
On Error Resume Next
Workbooks.Open Filename:=utvonal & FN
Workbooks("Célfüzet.xlsm").Activate
Sheets("Céllap").Activate
usor = Range("A" & Rows.Count).End(xlUp).Row
If usor > 1 Then usor = usor + 3
Range("A" & usor & ":M" & usor + 11).Value = Workbooks(FN).Sheets("Munka1").Range("A1:M12").Value
Workbooks(FN).Close False
Next
Application.CutCopyMode = False
End SubA Torol makróid szerepét nem látom át. Nem tudom, melyik füzetben torlik az adatokat.
-
Delila_1
veterán
válasz
logitechh
#42348
üzenetére
Két füzeted van: Eredeti.xlsm és Célfüzet.xlsm. Az utóbbiban van a Céllap.
Mindkét füzetben modulba kell tenned a makrót.Eredeti.xlsm-be a Másolás gombhoz rendelve:
Sub Masolas()
Dim utvonal As String
utvonal = "F:\Eadat\Excel fórumok\PH" 'Ezt írd át!
Range("C2:O13").Copy
' Selection.Copy 'A kijelölt területet másolja
On Error Resume Next 'Ha nincs nyitva a Célfüzet
Workbooks.Open Filename:=utvonal & "\Célfüzet.xlsm"
Workbooks("Célfüzet.xlsm").Activate
Sheets("Céllap").Activate
End SubCélfüzet.xlsm-be a Beillesztés gombhoz rendelve:
Sub Beilleszt()
Selection.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub -
Delila_1
veterán
válasz
logitechh
#42343
üzenetére
Ha másik füzetbe akarsz másolni, akkor a célfüzet céllapján kell feloldanod a lapvédelmet a makró számára.
Sub Masol_Beilleszt()
Workbooks("Célfüzet.xlsx").Sheets("Céllap").Protect Password:="Jelszo01", UserInterfaceOnly:=True
Range("C2:O13").Copy 'a másolandó lapról indulsz
Workbooks("Célfüzet.xlsx").Sheets("Céllap").Range("C15").PasteSpecial xlPasteValues
End Sub -
Delila_1
veterán
válasz
logitechh
#42339
üzenetére
Elég 1 makró, ami másol és beilleszt. Ha nem volt jelszóval védve a lap, a másolás után akkor is védve lesz.
Sub Masol_Beilleszt()
ActiveSheet.Protect Password:="Jelszo01", UserInterfaceOnly:=True
Sheets("Munka1").Range("C2:O13").Copy
Range("C15").PasteSpecial xlPasteValues
End SubSztanozs: a UserInterfaceOnly:=True a makró részére (és csakis a makró részére) engedélyezi a beillesztést a védett lap zárolt celláiba.
-
-
Delila_1
veterán
válasz
Sutyi73
#42316
üzenetére
Laphoz rendelt makróval megoldható.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value = "p" Then Target.Borders(xlDiagonalUp).LineStyle = xlContinuous
If Target.Value = "o" Then Target.Borders(xlDiagonalDown).LineStyle = xlContinuous
End SubAzért írtam meg "o" bevitelére is, mert nem tudom, melyik irányba szeretnéd dönteni az átlót. "p" esetében /, "o"-nál \.
-
Delila_1
veterán
válasz
dave0825
#42304
üzenetére
A DARABTELI függvénnyel rögtön meg tudod állapítani az egyes értékek darabszámát.
=darabteli(A:A;A1)Feltételes formázást is alkalmazhatsz az A oszlopra. A képlet
=darabteli(A:A;A1)>1
Ez az általad meghatározott formátummal hozza azokat a tételeket, amik 1-nél többször fordulnak elő az A oszlopban.Szerk.: látom, a darabteli függvényt közben Pakliman is megírta.
-
-
-
-
Delila_1
veterán
válasz
Fferi50
#42205
üzenetére
Egy keveset módosítottam, mert X-et tett oda is, ahova nem kellett volna, no meg a kérdezőnek .png képei vannak.
For Each Pic In PicsPic.Offset(0, -1).SelectOn Error Resume NextActiveSheet.Shapes.AddPicture Filename:=Path & Pic.Value & ".png", linktofile:=msoFalse, saveWithdocument:=msoTrue, Left:=Pic.Offset(0, -1).Left + 5, Top:=Pic.Top, Width:=50, Height:=60If Pic.Value = "" Or Err <> 0 ThenPic.Offset(0, -1).Value = "X"Pic.Offset(0, -1).Font.ColorIndex = 3On Error GoTo 0ElsePic.RowHeight = 60End IfNext -
-
Delila_1
veterán
válasz
Richard
#42179
üzenetére
Sub Lap_Tabla()Dim sor As Integer, CV, lap As Integer, oszlop As Integersor = 1For lap = 1 To Worksheets.CountWith Sheets(1)oszlop = 1.Cells(sor, oszlop) = Sheets(lap).NameFor Each CV In Sheets(lap).ListObjectsoszlop = oszlop + 1.Cells(sor, oszlop) = CV.NameNextEnd Withsor = sor + 1NextEnd Sub -
Delila_1
veterán
válasz
bucihost
#42170
üzenetére
Másik megoldás, hogy a "nagy piros x kép" ne növelje a fájl méretét.
A két, csillagokkal jelölt sor a kép méretét határozza meg. A 0.4-et írd át kedved szerint. Ki is hagyható ez a két sor.Sub PlacePics()Dim Path As String, Pics As Range, Pic As RangePath = "C:\Users\branyiczkif\Desktop\AjanlatKepek\kepek\"Set Pics = ActiveSheet.Range("B2:B20")For Each Pic In PicsPic.Offset(0, -1).SelectOn Error Resume NextActiveSheet.Pictures.Insert(Path & Pic.Value & ".png").SelectSelection.ShapeRange.ScaleWidth 0.4, msoFalse, msoScaleFromTopLeft '***Selection.ShapeRange.ScaleHeight 0.4, msoFalse, msoScaleFromTopLeft '***If VarType(Selection.ShapeRange) = vbError ThenPic.Offset(0, -1).Value = "X"Pic.Offset(0, -1).Font.ColorIndex = 3On Error GoTo 0End IfNext PicEnd Sub -
-
-
-
Delila_1
veterán
-
Delila_1
veterán
válasz
kokokka
#41994
üzenetére
A számok tizedes pontját cseréld ki tizedes vesszőkre a két új oszlopban.
Kijelölöd az A2:Avalahány cellát, majd a 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 jön a képlet:=A2=MEDIÁN(A2;B2;C2)
Már csak a formátumot kell megadnod.A megadott táblázatban véletlenül sincs olyan érték, ami megfelelne. -
Delila_1
veterán
válasz
Sutyi73
#41979
üzenetére
Kijelölöd a formázandó tartományt, pl. A1 : B300.
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: =$A1="P"
Fontos a $ jel az A előtt, ez határozza meg, hogy az A oszlop értékét figyelje mindkét oszlop formázásánál.
Megadod a formátumot. -
-
#41929
Delila_1
veterán
gyulazsolti
#41928
Delila_1
veterán
válasz
gyulazsolti
#41928
üzenetére
Igen, a sok tartalom miatt, vagy nem elég izmos a géped.
-
#41926
Delila_1
veterán
gyulazsolti
#41925
Delila_1
veterán
válasz
gyulazsolti
#41925
üzenetére
Egy vagy több oszlopodnál az autoszűrőben kiválasztottál valami szűrési feltételt. A szűrt oszlop(ok)ban az első sor cellájának jobb oldalán lévő lefelé mutató háromszög helyett egy tölcsér látszik. Ezt legördítve állíthatod be, hogy az összes tétel legyen látható. Azonnal helyreáll a sorrend, és kék (szűrt) helyett feketék lesznek a sorszámok.
-
Delila_1
veterán
válasz
Weareus
#41910
üzenetére
Kis magyarázat az előbbihez:
A darab2 függvény megadja az oszlop utolsó sorának a számát, feltéve, hogy nincsenek közöttük üres cellák.
Ezt a számot az indirekt függvénnyel az F után írjuk, ami a feltett kép szerinti F19 lesz. Ebből vonjuk le az F2 értékét. A többit tudod. -
-
Delila_1
veterán
válasz
csferke
#41861
üzenetére
Ahogy Fferi írta, csak makróval indíthatod a hangfájlt. A feltételes formázás is Fferi ajánlata szerint legyen.
Az N2 képlete legyen
=HA(FKERES(I5;Kupci!A1:N14;14;0)="";"";FKERES(I5;Kupci!A1:N14;14;0))
mert másképp üres cella találatánál nulla értéket ad.A laphoz (amelyiken a képlet van) rendeld a makrót.
Private Declare Function PlaySound Lib "winmm.dll" _Alias "PlaySoundA" (ByVal lpszName As String, _ByVal hModule As Long, ByVal dwFlags As Long) As LongConst SND_SYNC = &H0Const SND_ASYNC = &H1Const SND_FILENAME = &H20000Private Sub Worksheet_Change(ByVal Target As Range)Dim utvonal As String, WAVfile As StringIf Target.Address = "$I$5" ThenIf Len(Range("N23")) = 0 Thenutvonal = "F:\Wav" '*** saját útvonaladWAVfile = utvonal & "\" & "Bimm_bamm.wav" '*** saját hangfájlodCall PlaySound(WAVfile, 0&, SND_SYNC Or SND_FILENAME)End IfEnd IfEnd Sub -
Delila_1
veterán
Megpróbáltam újra, de valamiért úúútálja.
Itt vannak a makrók a Gomb 1, gomb 2, stb-hez rendelve.Sub Gomb1_Click()TorlesActiveSheet.Shapes("Gomb 6").Visible = TrueEnd SubSub Gomb2_Click()TorlesActiveSheet.Shapes("Gomb 7").Visible = TrueEnd SubSub Gomb3_Click()TorlesActiveSheet.Shapes("Gomb 8").Visible = TrueEnd SubSub Gomb4_Click()TorlesActiveSheet.Shapes("Gomb 9").Visible = TrueEnd SubSub Gomb5_Click()TorlesActiveSheet.Shapes("Gomb 10").Visible = TrueEnd SubSub Torles()ActiveSheet.Shapes.Range(Array("Button 6", "Button 7", "Button 8", "Button 9", "Button 10")).Visible = FalseEnd Sub
-
#41821
Delila_1
veterán
Nagyzoli27
#41820
Delila_1
veterán
válasz
Nagyzoli27
#41820
üzenetére
Nem lehet, de a keresőben a célkereszt szó beírásával találsz pár makrós megoldást.
Ha nem erre gondoltál, a cellába beírt =CÍM(SOR();OSZLOP())függvény beírja a címet. -
#41807
Delila_1
veterán
szricsi_0917
#41806
Delila_1
veterán
válasz
szricsi_0917
#41806
üzenetére
A zöld háttér képlete (persze a saját igényednek megfelelő értékekkel)=ÉS($A2>ÁTLAG(A:A)*20%; $A2<=ÁTLAG(A:A)*60%) -
-
Delila_1
veterán
válasz
bucihost
#41787
üzenetére
Nem lehet.
Ne vond össze a cellákat! Az AAA és BBB tétel mellé is írd be a Csomag1 nevet, akkor a szűrés mindkettőt felhozza.
Többször volt már itt a fórumon szó arról, hogy bár megengedi az Excel a cellák összevonását, de többnyire nem tudja úgy kezelni, ahogy szeretnénk. -
Delila_1
veterán
Az With – End With közötti rész az A:G oszlopban állít mindent alapra, az utolsó sor viszont csak a teljes lapra adható meg, és minden objektumot (szövegdoboz, rajz) töröl.
Sub Alapallas()
With Columns("A:G")
.Value = ""
.Interior.Color = xlNone
.Font.Size = 10
.Font.Bold = False
.Font.Underline = False
.Font.Name = "Tahoma"
.Font.Italic = False
End With
ActiveSheet.DrawingObjects.Delete
End Sub -
Delila_1
veterán
A lenti makrót másold be modulba. A Case utasításoknál írd be a rendes útvonalakat, ügyelve, hogy a végükön \ legyen. A csillagos sorba írd be a mentendő fájl nevét a "Fájlneve.pdf" helyére. A javítások után makróbarátként mentsd el a füzetet.
Sub Mentes()
Dim utvonal As String, x As Integer, FN As String
Application.DisplayAlerts = False
FN = "Fájlneve.pdf" '************
For x = 1 To 6
Select Case x
Case 1: utvonal = "F:\Eadat\Excel fórumok\"
Case 2: utvonal = "F:\Eadat\"
Case 3: utvonal = "..."
Case 4: utvonal = "..."
Case 5: utvonal = "..."
Case 6: utvonal = "..."
End Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=utvonal & FN, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next
Application.DisplayAlerts = True
End Sub -
Delila_1
veterán
válasz
jackal79
#41731
üzenetére
Laphoz rendeld a lenti, eseményvezérelt makrót (a módját lásd a Téma összefoglalóban):
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.WorksheetFunction.CountA(Rows(Target.Row)) > 0 Then
Application.EnableEvents = False
Range("A" & Target.Row) = Date
Application.EnableEvents = True
End If
End SubAz egyes sorok bármelyik cellájára kattintva az A-ban megjelenik a mai dátum, de csak akkor, ha a sorban bármelyik cellában van már adat. Ha másik oszlopba kell a dátum, akkor a
Range("A" & Target.Row) = Datesorban írd át az "A"-t.
-
Delila_1
veterán
válasz
#06658560
#41694
üzenetére
Felvettem egy segédoszlopot, a P-t, ahol összefűztem az összetartozó adatokat. A képlet a szerkesztőlécen látható.
A B3 képletét a zöld-, az E3-ét a sárga hátterű tartományba másoltam. A B1-ben és az E1-ben van a két cím, cellaformázással, vízszintes igazítással középre helyezve a B1:D1, ill. az E1:G1 tartományba.
-
#41689
Delila_1
veterán
MasterMark
#41688
Delila_1
veterán
válasz
MasterMark
#41688
üzenetére
Makróban a függvények angol nevét kell megadnod.
-
#41638
Delila_1
veterán
MasterMark
#41637
Delila_1
veterán
válasz
MasterMark
#41637
üzenetére
Az eredeti kérdésedből nem feltételeztem az ilyen irányú ismereteidet, mert nem akartad megadni, melyik oszlop szerint kell a szűrést végrehajtani, holott ezt alapvető ebben az esetben. Ha tudom, hogy értesz hozzá, másképp segítettem volna.
-
#41636
Delila_1
veterán
MasterMark
#41633
Delila_1
veterán
válasz
MasterMark
#41633
üzenetére
Félreértettem. Azt hittem, cellán belül nem jó helyről tüntettem el a szóközöket.
Így legalább "megszakértetted", és javítani is tudtad.Sok sikert a további makrózáshoz!
-
#41631
Delila_1
veterán
MasterMark
#41630
Delila_1
veterán
válasz
MasterMark
#41630
üzenetére
"a sortolást nem jó helyről kezdte", mert nem adtad meg.
Autoszűrő, sorszámozás, és formátum a lapokra:
Sub AutSzuro_Sorszam_Formatum()
Dim lap As Integer
For lap = 1 To Sheets.Count
Sheets(1).Range("A:J").Copy
Sheets(lap).Range("A:J").PasteSpecial xlPasteFormats
Sheets(lap).Range("A2").AutoFilter
Sheets(lap).Range("A3" & ":A" & Range("A3").End(xlDown).Row) = "=row()-2"
Next
End Sub
Új hozzászólás Aktív témák
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Árváltozás + játék DVD: Watch Dogs Deadsec Edititon
- Windows 10/11 Home/Pro , Office 2024 kulcsok
- Kaspersky, BitDefender, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- BLACK FRIDAY! - Jogtiszta Windows - Office & Vírusirtó licencek- Azonnal - Számlával - Garanciával
- LG 32GS94UX - 32" OLED / UHD 4K / 240Hz - 480Hz & 0.03ms / 1300 Nits / NVIDIA G-Sync / AMD FreeSync
- BESZÁMÍTÁS! ASRock B450M R5 3600 16GB DDR4 256GB SSD 2TB HDD RTX 2060 Super 8GB RAMPAGE Shiva 450W
- BESZÁMÍTÁS! ASUS TUF B760M i9 14900K 32GB DDR4 1TB SSD RX 7900 XTX 24GB ZALMAN Z1 Plus Seasonic 850W
- 155 - Lenovo LOQ (15IRH8) - Intel Core i5-13505H, RTX 4060
- Apple iPhone 12 Mini 64GB, Kártyafüggetlen, 1 Év Garanciával
Állásajánlatok
Cég: ATW Internet Kft.
Város: Budapest
Cég: BroadBit Hungary Kft.
Város: Budakeszi