-
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
-
#42446
Delila_1
veterán
Nagyzoli27
#42445
Delila_1
veterán
válasz
Nagyzoli27
#42445
üzenetére
Ez ugyanaz, mint az előző. Ebbe a füzetben is indíthatod a makrót.
-
#42444
Delila_1
veterán
Nagyzoli27
#42443
Delila_1
veterán
válasz
Nagyzoli27
#42443
üzenetére
Mert annyi adat van a 2. táblában, ahol az első duplikációi nem szerepelnek.
-
#42442
Delila_1
veterán
Nagyzoli27
#42440
Delila_1
veterán
válasz
Nagyzoli27
#42440
üzenetére
Próbáld Itt.
-
#42439
Delila_1
veterán
Nagyzoli27
#42437
Delila_1
veterán
válasz
Nagyzoli27
#42437
üzenetére
Lehet, hogy csak egyszer lesz szükséged a makró eredményére. Itt van.
-
#42438
Delila_1
veterán
Nagyzoli27
#42437
Delila_1
veterán
válasz
Nagyzoli27
#42437
üzenetére
Módosítottam a makrón. A sok sorod miatt a változókat Long típusúnak kellett megadni, és azt nem írtad, hogy az első táblázatban vannak tételek, amikhez nem tartozik kapcsolódó ID.
Működik a makró, de nagyon sokáig fut. Érdemes megnézned Mutt ajánlatát.
Azért bemásolom ide a makrót. Kibővítettem azzal, hogy az A oszlop tartalmát átmásolja a D oszlopba, majd eltávolítja az ismétlődéseket. A makrót tartalmazó fájlt makróbarátként kell elmenteni.Sub Kapcsolodo()
Dim sor1 As Long, sor2 As Long, usor1 As Long, usor2 As Long
Columns("A:A").Copy Range("D1")
Columns("D:D").RemoveDuplicates Columns:=1, Header:=xlYes
Range("B1").Copy Range("E1")
usor1 = Range("A1").End(xlDown).Row
usor2 = Range("D1").End(xlDown).Row
For sor2 = 2 To usor2
For sor1 = 2 To usor1
If Cells(sor1, 2) <> "" Then
If Cells(sor2, 4) = Cells(sor1, 1) Then
If Cells(sor2, 5) = "" Then
Cells(sor2, 5) = Cells(sor1, 2)
Else
Cells(sor2, 5) = Cells(sor2, 5) & "|" & Cells(sor1, 2)
End If
End If
End If
Next
Next
MsgBox "Kész van", vbInformation, "Értesítés"
End Sub -
#42435
Delila_1
veterán
Nagyzoli27
#42432
Delila_1
veterán
válasz
Nagyzoli27
#42432
üzenetére
Egy rövid makróval megoldható.
Sub Kapcsolodo()
Dim sor1 As Integer, sor2 As Integer, usor1 As Integer, usor2 As Integer
usor1 = Range("A" & Rows.Count).End(xlUp).Row
usor2 = Range("D" & Rows.Count).End(xlUp).Row
For sor2 = 2 To usor2
For sor1 = 2 To usor1
If Cells(sor2, "D") = Cells(sor1, 1) Then
If Cells(sor2, 5) = "" Then
Cells(sor2, 5) = Cells(sor1, 2)
Else
Cells(sor2, 5) = Cells(sor2, 5) & " | " & Cells(sor1, 2)
End If
End If
Next
Next
End Sub -
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.
Új hozzászólás Aktív témák
- Építő/felújító topik
- Arc Raiders
- Google Pixel topik
- Luck Dragon: Asszociációs játék. :)
- iPhone topik
- Okos Otthon / Smart Home
- Star Trek
- MWC 2026: Megnéztük, hol tart a Clicks Power Keyboard és Communicator
- Sony WF-1000XM6 – ez évi etalon?
- Befutott a régóta várt, sok P-maggal kitömött, LGA1700-as Core sorozat
- További aktív témák...
- Xbox / Microsoft Store feltöltőkártya kód (digitális, HU) több címlet, több db, azonnal, olcsón
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Vírusirtó, Antivirus, VPN kulcsok GARANCIÁVAL!
- Adobe Előfizetések - Adobe Creative Cloud All Apps - 12 Hónap - 15% AKCIÓ
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest