-
Mobilarena
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
-
#28662
Delila_1
veterán
szőröscica
#28660
Delila_1
veterán
válasz
szőröscica
#28660
üzenetére
Nem kell külön beolvastatni a fájlneveket, majd másolni, végül törölni a felesleges sorokat. Az alábbi makró mindegyik műveletet elvégzi.
Két dolgot kell átírnod benne, az útvonalat, ahonnan a fájlokat behívod, és a kiterjesztést, ha 2007-es verziónál régebbi Excelt használsz.
Sub Osszemasolas()
Dim FN As String, utvonal As String, WS As Worksheet
Dim hova As Long, tabla As Range, CV As Object
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WS = ActiveWorkbook.ActiveSheet
utvonal = "F:\Eadat\Tmp\" 'fájlok útvonala, írd át
FN = Dir(utvonal & "*.xlsx") '2007-es előtti verziónál xls-re írd át
Do While FN <> ""
hova = Application.WorksheetFunction.CountA(Columns(1)) + 1
Workbooks.Open utvonal & FN
Sheets("Data").Select
Range("A1").Select
Set tabla = Cells.CurrentRegion
tabla.Offset(1, 0).Resize(tabla.Rows.Count - 1, tabla.Columns.Count).Copy
WS.Cells(hova, "A").PasteSpecial Paste:=xlPasteAll
Windows(FN).Close False 'Zárja a megnyitott fájlt mentés nélkül
For Each CV In Selection
If CV = "q" Or CV = "r" Then Rows(CV.Row).Delete
Next
FN = Dir()
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Kész", vbInformation
End Sub -
#28659
Delila_1
veterán
coldfirexx
#28629
Delila_1
veterán
válasz
coldfirexx
#28629
üzenetére
A lenti makró a lapon lévő diagramok címéből eltünteti a "0%" szövegrészt.
Sub NullaNyet()
Dim CV As Integer, szoveg As String
For CV = 1 To ActiveSheet.ChartObjects.Count
ActiveSheet.ChartObjects(CV).Activate
szoveg = ActiveChart.ChartTitle.Characters.Text
szoveg = Application.WorksheetFunction.Substitute(szoveg, "0%", "")
ActiveChart.ChartTitle.Characters.Text = szoveg
Next
End Sub -
Delila_1
veterán
válasz
boomkat88
#28624
üzenetére
Sub Dupla()
Dim sor As Long, usor As Long
Application.ScreenUpdating = False
usor = Range("A1").End(xlDown).Row
usor = usor * 2
For sor = 2 To usor Step 2
Cells(sor, "A").Select
Selection.EntireRow.Insert
Cells(sor, "A") = Cells(sor - 1, "A")
Next
Application.ScreenUpdating = True
End Sub -
-
Delila_1
veterán
válasz
dudu_14
#28596
üzenetére
A lapodhoz rendelt makróban kell megadnod a műveleteket.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$6" Then
'ide másold a saját makródat a Sub és End Sub sorok nélkül
End If
End SubA rejtés feloldásához nem szükséges ciklust betenned, gyorsabb és egyszerűbb megoldást alkalmazz:
If Target.Address = "$D$6" Then _
Rows("1:" & ActiveSheet.UsedRange.Rows.Count).Hidden = False -
-
Delila_1
veterán
válasz
karlkani
#28582
üzenetére
Elrejti a megjegyzést a
Range("I" & Target.Row).Comment.Text Text:=ertek & " Ft/liter"
sor után beszúrt
Range("I" & Target.Row).Comment.Visible = False
sor.
Tudtommal nincs olyan beállítás, ami eleve automatikus mérettel szúrja be a megjegyzést.Automatikus méretre állítás a D és I oszlopban:
Sub Auto_Meret()
Dim CV, kom, ter As Range
Set ter = Range("D:D, I:I")
For Each CV In ter
Set kom = Range(CV.Address).Comment
If Not kom Is Nothing Then 'ha van megjegyzés
Range(CV.Address).Comment.Shape.Select
Selection.AutoSize = True
End If
Next
End SubEzt a makrót mudulba kell másolni.
-
Delila_1
veterán
válasz
karlkani
#28580
üzenetére
Cseppenként adagolod a feladatot.
Az új makró előállítja a megjegyzést automatikus mérettel, a bevitel sorának az I oszlopában. Teszi ezt akkor, mikor a D, vagy I oszlopba viszel be értéket.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ertek As Double
If Target.Column = 4 Or Target.Column = 9 Then 'D vagy I oszlop
Range("I" & Target.Row).Select
With Range("I" & Target.Row)
On Error Resume Next
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
.Comment.Text Text:=ertek & " Ft/liter"
.Comment.Shape.Select
Selection.AutoSize = True
End With
If IsNumeric(Range("D" & Target.Row)) And _
IsNumeric(Range("I" & Target.Row)) Then
On Error Resume Next
ertek = Round(Range("D" & Target.Row) / Range("I" & Target.Row), 1)
Range("I" & Target.Row).Comment.Text Text:=ertek & " Ft/liter"
End If
Else: Range("I5").Comment.Text Text:="0 Ft/liter"
End If
Range(Target.Address).Select
End SubMár csak azt nem tudom, hogy a D/I érték, vagy az I/D kell a megjegyzésbe. Az
ertek = Round(Range("D" & Target.Row) / Range("I" & Target.Row), 1)
sor a D/I-vel számol. Ha ez nem jó, írd át így:
ertek = Round(Range("I" & Target.Row) / Range("D" & Target.Row), 1)
Szöveges bevitt adat esetén a megjegyzés szövege 0 Ft/liter lesz.
-
Delila_1
veterán
válasz
karlkani
#28578
üzenetére
Szivi!
Kezdd azzal, hogy az I5 cellához rendelsz egy megjegyzést. A keretén bal klikk, ekkor a keret az előző sraffozottról átalakul sűrű pontozottá. Ezen jobb klikk, Megjegyzés formázása. Az Igazítás fülön jelöld be az Automatikus méret négyzetet.
A makró
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$I$5" Then
If IsNumeric(Range("I5")) And IsNumeric(Range("D5")) Then
Range("I5").Comment.Text Text:="Az I5 és D5 cella hányadosa: " _
& Range("I5") / Range("D5") & ""
Else: Range("I5").Comment.Text Text:="0"
End If
End If
End SubSzöveg nélkül a
Range("I5").Comment.Text Text:="Az I5 és D5 cella hányadosa: " _
& Range("I5") / Range("D5") & ""sor
Range("I5").Comment.Text Text:=Range("I5") / Range("D5") & "" -
Delila_1
veterán
válasz
karlkani
#28574
üzenetére
A lapodhoz kell rendelned a makrót.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$10" Or Target.Address = "$F$5" Then
If IsNumeric(Range("B10")) And IsNumeric(Range("F5")) Then
Range("C3").Comment.Text Text:="A B10 és F5 cella hányadosa: " _
& Range("B10") / Range("F5") & ""
Else: Range("C3").Comment.Text Text:="0"
End If
End If
End SubA példában a C3 cella megjegyzésében jelenik meg a B10 és F5 cella hányadosa. Könnyen átírhatod a saját celláidra.
Szerk.: érdemes a megjegyzést automatikus méretűre állítani.
-
#28561
Delila_1
veterán
the radish
#28560
Delila_1
veterán
válasz
the radish
#28560
üzenetére
Szívesen (a szerintem semmit).
-
#28559
Delila_1
veterán
the radish
#28558
Delila_1
veterán
válasz
the radish
#28558
üzenetére
Sajnálom, csak a füzetek felépítése, és a teljes feladat ismeretében mondhatnék esetleg valamit.
-
#28557
Delila_1
veterán
the radish
#28555
Delila_1
veterán
válasz
the radish
#28555
üzenetére
Valószínű, hogy meg lehet oldani, de így vakon kaparászva nem tudok segíteni.
-
#28552
Delila_1
veterán
the radish
#28551
Delila_1
veterán
válasz
the radish
#28551
üzenetére
Az Else ágba írtam be két sort, és akkor nincs szükség a külön makróra.
Else
ig = Application.Match(sorszam, Columns(1), 1)
Rows(tol & ":" & ig).copy WSM.Range("A2")
Range("A:E").copy WSM.Sheets("Munka2").Range("A1") '1
WSI.Activate '2
' Masolas 'Itt indul a saját makród ****** megjegyzésbe tettem
sorszam = sorszam + 1 'növeljük a keresendő értéket
End IfHiába írtam át a makród nevét, még mindig van valami disznóság, másképp a VBE átírta volna a copy-t Copyra.
-
#28550
Delila_1
veterán
the radish
#28548
Delila_1
veterán
válasz
the radish
#28548
üzenetére
Most hirtelen azt látom nagy hibának, hogy a makród neve egy VBA-s kulcsszó, copy.
Nézd meg, hogy pl. az első makró Else ágában, aRows(tol & ":" & ig).copy WSM.Range("A2")
sorban a Copy utasítást nem is váltotta át nagy kezdőbetűre, mert a copy című makródként értelmezi.
-
#28546
Delila_1
veterán
the radish
#28543
Delila_1
veterán
válasz
the radish
#28543
üzenetére
A saját makród végén állj vissza oda, ahol a makró előtt voltál.
-
#28541
Delila_1
veterán
the radish
#28540
Delila_1
veterán
válasz
the radish
#28540
üzenetére
Nézd meg, nincsenek-e véletlenül azonos nevű változók a két makróban. Nem lehetnek, mert akkor a meghívott makró változói felülírják az indító makró változóinak az értékét.
-
#28503
Delila_1
veterán
valyogvisko
#28502
Delila_1
veterán
válasz
valyogvisko
#28502
üzenetére
Akkor nosza!
-
#28501
Delila_1
veterán
valyogvisko
#28500
Delila_1
veterán
válasz
valyogvisko
#28500
üzenetére
Feltételeztem, hogy mindkét lapon van címsorod, a tényleges adatok a 2. sorban kezdődnek.
Másik feltételezésem, hogy a B lapon az AA oszlopban már nincsenek adataid.A lenti makró a B lap AA oszlopába beírja a DARABTELI függvényt, ami megnézi, megtalálható-e az A oszlopában szereplő név az A lapon.
Ezután egy ciklusban törli az itt is, ott is szereplő nevek sorát, de csak a B lapon.A makróban megjegyzést tettem azokhoz a sorokhoz, ahol át kell írnod a lapok nevét, összesen 3 helyen.
Sub Duplat_Szuntet()
Dim sor As Long, usor As Long
Dim WSA As Worksheet, WSB As Worksheet
Set WSA = Sheets("A") '**********
Set WSB = Sheets("B") '**********
usor = Application.CountA(WSB.Columns(1))
WSB.Range("AA2:AA" & usor) = "=COUNTIF(A!A:A,A2)" 'Itt az A! módosítandó *********
With WSB
For sor = usor To 2 Step -1
If .Cells(sor, "AA") > 0 Then .Rows(sor).Delete Shift:=xlUp
Next
.Columns("AA") = ""
End With
End Sub -
#28496
Delila_1
veterán
valyogvisko
#28493
Delila_1
veterán
válasz
valyogvisko
#28493
üzenetére
Add meg pontosan, melyik lapnak melyik oszlopában szerepelnek a nevek.
Az ilyen "mondjuk legyen A" meghatározások miatt többször kell dolgozni annak, a segítségedre siet.Az sem mindegy, hogy a 2. lapon csak azt a bizonyos cellát kell törölni, vagy az egész sort.
-
#28495
Delila_1
veterán
the radish
#28491
Delila_1
veterán
válasz
the radish
#28491
üzenetére
Semmiképp ne Excelben oldd meg!
Nézz utána a Word körlevél funkciójának.
-
#28490
Delila_1
veterán
ritterkrisz
#28489
Delila_1
veterán
válasz
ritterkrisz
#28489
üzenetére
Igen. Akkor látod, és törölheted is.
-
#28488
Delila_1
veterán
ritterkrisz
#28485
Delila_1
veterán
válasz
ritterkrisz
#28485
üzenetére
Autoszűrő?
-
Delila_1
veterán
válasz
twingos
#28473
üzenetére
Formázd meg a D oszlopot előre, legyen # ##0" db" az egyéni kategóriában.
Rendeld a lapodhoz a lenti makrót:Private Sub Worksheet_Change(ByVal Target As Range)
Dim talal, WF As WorksheetFunction
Set WF = WorksheetFunction
Application.EnableEvents = False
If Target.Column = 1 Then
If WF.CountIf(Columns(1), Target) > 1 Then
If WF.CountIf(Columns(5), Target) = 0 Then
talal = Range("E" & Rows.Count).End(xlUp).Row + 1
Range("E" & talal) = Target
Range("D" & talal) = WF.CountIf(Columns(1), Target)
Else
talal = Application.Match(Target, Columns(5), 0)
End If
Range("D" & talal) = WF.CountIf(Columns(1), Target)
End If
End If
Application.EnableEvents = True
End Sub -
Delila_1
veterán
válasz
twingos
#28471
üzenetére
Legyen a B2 képlete =DARABTELI(A$2:A2;A2). Ügyelj a $ jelre. Ezt lemásolod a többi adatod mellé. Ahol 1-nél nagyobb számot látsz, ott már nem először szerepel az adat. Szűrheted is az oszlopot az 1-nél nagyobb értékekre.
Más oszlopba is írhatod a képletet, ha a B foglalt.
Adhatsz A2-től az oszlopodra feltételes formázást. A képlet =DARABTELI(A:A;A2)>1
-
-
Delila_1
veterán
-
-
Delila_1
veterán
Erre a kódrészletre többször kerül sor a leírásod szerint.
Mikor első esetben hibára fut, a hibakódot megjegyzi. Ha az On Error Resume Next-tel át tudtál lépni a hibán, a művelet elvégzése után le kell nulláznod a hibakódot, hogy a következő futtatáskor ne ezzel a hibával induljon. Nem tudom, hova érdemes beírni a nullázást, legegyszerűbb, ha már eleve 0 hibakóddal indítod a programrészt az On Error Resume Next sor fölött az On Error Goto 0 sorral.
-
Delila_1
veterán
válasz
tzimash
#28399
üzenetére
Sub mm()
Dim sor As Long, usor As Long, ertek
usor = Range("B" & Rows.Count).End(xlUp).Row
For sor = usor To 2 Step -1
ertek = Cells(sor, "B")
If Not InStr(Cells(sor, "C"), "VBS/BS ") > 0 And _
Cells(sor, "F") = 8960 And Cells(sor, "D") = "J" _
And Not (ertek = 2381273 Or ertek = 2381389 Or ertek = 2587841 _
Or ertek = 2437821 Or ertek = 2531518 Or _
ertek = 2417707 Or ertek = 2832690) Then
Rows(sor).Delete Shift:=xlUp
End If
Next
End Sub -
#28388
Delila_1
veterán
szatocs1981
#28387
Delila_1
veterán
válasz
szatocs1981
#28387
üzenetére
Passz.
-
#28382
Delila_1
veterán
szatocs1981
#28377
Delila_1
veterán
válasz
szatocs1981
#28377
üzenetére
Működik!
Botorul a 3 cellába (D1:D3) egyszerre vittem be a képletedet.
-
Delila_1
veterán
Itt egy saját függvény.
Function Megkeres(tartomany As Range, ertek As String)
Dim CV As Range
For Each CV In tartomany
If InStr(CV, ertek) Then
Megkeres = CV
Exit Function
End If
Next
Megkeres = "Nincs " & ertek & " a tartományban"
End FunctionA cellába beírod =megkeres(A1:A9;"nok")
-
#28378
Delila_1
veterán
szatocs1981
#28377
Delila_1
veterán
válasz
szatocs1981
#28377
üzenetére
IGAZ, vagy HAMIS értéked ad, értelemszerűen.
-
#28375
Delila_1
veterán
szatocs1981
#28371
Delila_1
veterán
válasz
szatocs1981
#28371
üzenetére
Nálam sem akarja az igazságot. Egyébként huba csíszott a képletedbe, a sor($1:$100)) elé bekerült egy } karakter.
-
#28370
Delila_1
veterán
szatocs1981
#28369
Delila_1
veterán
válasz
szatocs1981
#28369
üzenetére
Igaz.
-
#28368
Delila_1
veterán
szatocs1981
#28367
Delila_1
veterán
válasz
szatocs1981
#28367
üzenetére
Hol írtam?
-
-
-
#28329
Delila_1
veterán
the radish
#28328
Delila_1
veterán
válasz
the radish
#28328
üzenetére
Akkor segítene más.
Szívesen.
-
#28327
Delila_1
veterán
the radish
#28326
Delila_1
veterán
válasz
the radish
#28326
üzenetére
Az eredeti makró végére, az End Sub fölé tegyél be egy sort:
WSM.Rows(1) = ""
Ennyi az egész, ezzel a másolt lap első sorából kitörlöd az adatokat.
-
#28325
Delila_1
veterán
the radish
#28322
Delila_1
veterán
válasz
the radish
#28322
üzenetére
Figyelmetlenül olvastam az előbb.
Egy jól működő makrót ne írjunk át azért, amit könnyedén a makró nélkül is elintézhetsz. Kijelölöd a címsort, és nyomsz egy Delete-t. Ha meg úgyis törlődik, akkor ezt sem kell billentyűzetről elvégezned.
-
#28324
Delila_1
veterán
the radish
#28322
Delila_1
veterán
válasz
the radish
#28322
üzenetére
Rows(1).Copy WSM.Range("A1") 'fejléc másolása ezt sort töröld ki a makróból.
-
Delila_1
veterán
válasz
tzimash
#28319
üzenetére
Másold át a fejlécet egy új lapra.
Használd az autoszűrőt az eredeti lapon. Megadhatod, hogy azok a sorok legyen láthatóak, amelyek tartalmazzák a J karaktert. Ezeket a teljes sorokat kijelölöd, Ctrl+c-vel másolod, az új lap A2 cellájába Ctrl+v-vel beilleszted.
Marad a kijelölés az első lapon, ezeket a sorokat törlöd.
-
Delila_1
veterán
válasz
#81999360
#28315
üzenetére
Túl sok az Excel lelkének, nem fogadja el a ##.##.##.##-#### formátumot az egyéni kategóriában. Javaslom, hogy a beírás oszlopát szöveg formátumra vedd, és egy segédoszlopban az
=BAL(A1;2)&"." & KÖZÉP(A1;3;2) &"." & KÖZÉP(A1;5;2) &"." & KÖZÉP(A1;7;2) &"-" &JOBB(A1;4)
képlettel formázd a kedved szerint.
-
Delila_1
veterán
-
Delila_1
veterán
válasz
Mittu88
#28305
üzenetére
Az On Error Resume Next hibát generál, ha nem tudja megnyitni a következő sorban a fájlodat.
A megnyitási hiba kódja az 1004. Mikor bejön ez a hibakód, felteszi a kérdést
valasz = MsgBox("Újrahívás", vbYesNo + vbExclamation, "Új próbálkozás")
Igen válasz esetén kilép a Sub-ból, Nem-nél az Ujra címkéhez ugrik, ahol megszüntetjük a hibakódot az
On Error GoTo 0 sorral, másképp hibát jelez akkor is, ha most már meg tudja nyitni a fájlt.
Ez a lenullázó sor tulajdonképpen a 2. próbálkozástól érdekes, első esetben 0 a hibakód. -
#28293
Delila_1
veterán
m.zmrzlina
#28292
Delila_1
veterán
válasz
m.zmrzlina
#28292
üzenetére
"nagyobb hajlam van arra, hogy kitaláld a hiányzó peremfeltételeket"
Talán azért, mert úgy gondolom, a kérdezőt elbizonytalaníthatja a sok újabb kérdés. Nem szeretnék senkiből kisebbségi érzést kiváltani, inkább 3× válaszolok.
Szerencsére ezen a fórumon nem macerálják az emberek egymást, de van olyan hely, ahol porig aláznak mindenkit, aki kérdez.
-
-
#28289
Delila_1
veterán
m.zmrzlina
#28287
Delila_1
veterán
válasz
m.zmrzlina
#28287
üzenetére
De haragszom az n-edik átírás után, csak nem nagyon. Abból indulok ki, hogy aki kérdez, ebben a témában nem olyan profi, mint valami másban, amiben viszont én nem vagyok jártas, és amiben nem tudnék egy tisztességes, lényegretörő kérdést feltenni – ha szükségem lenne rá.
Vajh' a lényegretörőt a hamarosan megjelenő új helyesírási szótár szerint így kell írni?
-
![;]](http://cdn.rios.hu/dl/s/v1.gif)
-nek váltasz át általános formátumra?
Új hozzászólás Aktív témák
Hirdetés
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- Bontatlan - BATTLEFIELD 1 Collectors Edition - Játékszoftver nélkül
- Bitdefender Total Security 3év/3eszköz! - Tökéletes védelem, Most kedvező áron!
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- BESZÁMÍTÁS! ASROCK H310CM i5 8400 16GB DDR4 256GB SSD 1TB HDD GTX 1060 3GB Rampage SHIVA TT 500W
- Epson Expression 12000 XL Nagyformátumú A3 szkenner
- Hp USB-C/Thunderbolt 3 dokkolók: USB-C Universal, G2, G4, G5, Hp Elite/Zbook- Thunderbolt 4 G4
- TAVASZI BOMBA AKCIÓK! STEAM, UBISOFT CONNECT, EA APP, XBOX EREDETI KULCSOK 100% GARANCIA
- Bomba ár! Lenovo IdeaPad 330S-15IKB - i5-8G I 8GB I 256SSD I 15,6" FHD I HDMI I Cam I W11 I Gari!
Állásajánlatok
Cég: CAMERA-PRO Hungary Kft
Város: Budapest
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest