-
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
-
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
válasz
Sziszmisz
#15367
üzenetére
Egy rövid makróval megoldhatod.
Sub Szetvalaszt()
Dim sor%, szin$, vesszo%
sor% = 2
Do While Cells(sor%, 1) > ""
szin$ = Cells(sor%, 4)
vesszo = InStr(szin$, ",")
If vesszo Then
Range("A" & sor% + 1).EntireRow.Insert
Range(Cells(sor%, 1), Cells(sor%, 3)).Copy Cells(sor% + 1, 1)
Cells(sor%, 4) = Left(szin$, vesszo - 1)
Cells(sor% + 1, 4) = Right(szin$, Len(szin$) - vesszo - 1)
End If
sor% = sor% + 1
Loop
End Sub -
Delila_1
veterán
válasz
bandus
#15362
üzenetére
Szívesen.
Így adhatod hozzá az előzőhöz az újabb értéket:
Sub period()
Dim per%, ertek, oszlop%
'A D5:AD5 tartomány kiürítése (evés előtt mosogatunk elv szerint)
Range(Cells(5, 4), Cells(5, 30)).ClearContents
per% = Range("A1"): ertek = Range("B1")
For oszlop% = 4 To 30 Step per%
Cells(5, oszlop) = Cells(5, oszlop%) + ertek
Next
per% = Range("A2"): ertek = Range("B2")
For oszlop% = 4 To 30 Step per%
Cells(5, oszlop) = Cells(5, oszlop%) + ertek
Next
End Sub -
Delila_1
veterán
válasz
bandus
#15355
üzenetére
Szívesen.
Itt csupán a Step-et nem ismerted, ami a lépésközt határozza meg. Mikor nem adjuk meg, az alapértékként beállított 1-et használja a makró.Szerk.:
A Step értékének negatív számot is adhatunk, pl. mikor bizonyos sorokat törölni akarunk. Ilyenkor érdemes a táblázat aljáról indulni a teteje felé.Sub torol()
Dim sor%
For sor% = 20 To 2 Step -1
If Cells(sor%, 1) < 300 Then Rows(sor%).Delete
Next
End Sub -
Delila_1
veterán
válasz
bandus
#15353
üzenetére
Sub period()
Dim per%, ertek, oszlop%
per% = Range("A1"): ertek = Range("B1")
For oszlop% = 4 To 30 Step per%
Cells(5, oszlop%) = ertek
Next
End SubA periódusok mértékét a per% változó veszi az A1-es cellából, a beírandó értéket az ertek a B1-ből. A fenti makró a 30. oszlopig írja be az azonos értékeket.
-
Delila_1
veterán
válasz
zannor
#15321
üzenetére
Ennél rosszabb példát fel sem lehetett volna adni. Ilyenkor szoktuk visszadobni a listát azzal, hogy ha normális eredményeket várnak, akkor tisztességesen adják meg a kiinduló adatokat.
Olyan veszedelmes képletekkel lehet helyrehozni a táblázatot, hogy inkább levélben küldeném el a megoldást – feltéve, hogy megadod az elérhetőségedet privátban.
-
Delila_1
veterán
válasz
zannor
#15318
üzenetére
Eljutottál a FKERES-ig, de megállt a tudomány. Akkor azt a részt megoldottad, vagy nem?
A feltételeket hibásan adták meg, az első és a harmadik üti egymást. A harmadik valószínűleg 2700-3883 akart lenni. A kérdés feltevője lehet trehány, a választ adó nem.
![;]](//cdn.rios.hu/dl/s/v1.gif)
A szűrésnél találsz olyan opciót, hogy a vége. Ennél megadod pl. a Kft-t, VAGY operátorral pedig a kft-t.
-
#15267
Delila_1
veterán
Fire/SOUL/CD
#15266
Delila_1
veterán
válasz
Fire/SOUL/CD
#15266
üzenetére
Egy kicsit variálva minden hibás címet kiír.
Sub valami()
Dim MyRange As Range
Dim MyCell As Range
Dim MyRow
Set MyRange = Range("C1:C100")
MyRow = 1
For Each MyCell In MyRange
If Application.WorksheetFunction.IsError(MyCell) Then
Range("M" & MyRow) = MyCell.Address
MyRow = MyRow + 1
End If
Next
End Sub -
-
#15248
Delila_1
veterán
medvezsolt
#15247
Delila_1
veterán
válasz
medvezsolt
#15247
üzenetére
Akkor most kezdd el lassan az elejétől.
Hova írod az X-et?
Hol jelenjen meg a dátum?
Ahol X van, a dátum mindig az aktuális legyen, vagy az, amikor beírtad az X-et? -
#15246
Delila_1
veterán
medvezsolt
#15244
Delila_1
veterán
válasz
medvezsolt
#15244
üzenetére
Nem közölted, hova akarod írni az X-et, és hol legyen a dátum.
A makró akkor írja be a B oszlopba a dátumot, ha az A oszlopba írod be az X-et.
A laphoz rendelt a makrót.Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target = "X" Then _
Range("B" & Target.Row) = Date
End Sub -
Delila_1
veterán
Vigyél be A2-től feltételes formázást. A képlet:
=A2=A1
és adj fehér színt a karaktereknek. Ott maradnak az értékek, de nem látszanak.
Ha ez nem jó, írok rá egy makrót.Belefért az időbe, itt a makró:
Sub valami()
Dim sor As Integer
sor = 2
Do While Cells(sor, 1) > ""
If Cells(sor, 1) = Cells(sor - 1, 1) Then Cells(sor, 1) = ""
sor = sor + 1
Loop
End Sub -
Delila_1
veterán
válasz
w.miki
#15149
üzenetére
Beírod pl. az A1 cellába a "3halado_1/Halado03_mondatok_001"szöveget. Lemásolod, és örülsz, hogy szépen növeli a sorszámot.
B1 -> =A1&"_angol.mp3" , ezt is lemásolod.
Kijelölöd és másolod a B oszlopot, A1-re állsz, és irányítottan, értékként beilleszted. A B oszlop tartalmát törölheted.Ezt gyorsabban végrehajtod, mint ahogy én leírtam.
-
Delila_1
veterán
Mivel nem árultad el, hol lesznek az adatok, a D2:E8 tartományra írtam meg, majd átalakítod a makrókat.
Sub Start()
UserForm1.ListBox1.List = Sheets("Munka1").Range("E2:E8").Value
UserForm1.Show
End SubPrivate Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim sor%, usor%, nev$
sor% = Me.ListBox1.ListIndex + 1
usor% = Cells(Rows.Count, "A").End(xlUp).Row + 1
nev$ = Me.ListBox1.List(Me.ListBox1.ListIndex)
Range("B" & usor%) = nev$
Range("A" & usor%) = Range("D" & Application.WorksheetFunction.Match(nev$, Columns(5), 0))
End Sub -
Delila_1
veterán
Például így oldhatod meg.
A listbox tartománya a Munka1 lap A1:A10.Ezzel indítod a userformot.
Sub start()
UserForm1.ListBox1.List = Sheets("Munka1").Range("A1:A10").Value
UserForm1.Show
End SubA listbox kiválasztott elemén duplaklikkre beírja az elemet a füzet aktuális cellájától egy cellával jobbra.
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim sor As Integer
sor = Me.ListBox1.ListIndex + 1
Selection.Offset(, 1) = Range("A" & sor)
End SubA +1 azért kell, mert az index nullával kezdődik.
-
Delila_1
veterán
válasz
zz76zz
#14942
üzenetére
Eléggé dodonai módon fogalmaztál. Van egy oszlop cikkszámokkal... Hol van az az oszlop?
Írtam egy makrót, ahol a Munka1 lap A oszlopában van a cikkszám, az első sorban a dátumok. A cikkszámok sorában, a fenti dátumok oszlopában az aznap rendelt mennyiségek.
Ezekből az adatokból készít a makró egy új táblázatot a Munka2 lapon, ahol az A oszlop a cikkszámot tartalmazza, a B a dátumot, a C pedig a rendelt mennyiséget. Azokat a napokat, mikor nem volt a cikkszámhoz tartozó rendelés, kihagyja.
Ha nem ilyent szerettél volna, magadra vess a homályos fogalmazás miatt.
Sub valami()
Dim sor%, usor%, oszlop%, uoszlop%, WS As Worksheet
Dim sorW%, cikksz, f As Boolean
usor% = ActiveSheet.UsedRange.Rows.Count
uoszlop% = ActiveSheet.UsedRange.Columns.Count
Set WS = Sheets("Munka2")
sorW% = 2
Sheets("Munka1").Select
Application.ScreenUpdating = False
For sor% = 2 To usor%
cikksz = Cells(sor%, 1)
For oszlop% = 2 To uoszlop%
If Application.WorksheetFunction.CountA(Rows(sor%)) > 1 Then
f = False
If Cells(sor%, oszlop%) > 0 Then
WS.Cells(sorW%, 1) = cikksz
WS.Cells(sorW%, 2) = Cells(1, oszlop%)
WS.Cells(sorW%, 3) = Cells(sor%, oszlop%)
f = True
End If
End If
If f Then sorW% = sorW% + 1
Next
Next
Sheets("Munka2").Select
Application.ScreenUpdating = False
End SubSzerk.: a sorok és oszlopok számától függően elmókuskálhat a makró egy darabig.
-
Delila_1
veterán
válasz
#05304832
#14963
üzenetére
Az összefűzésből kihagyom az F oszlopot, az M oszlopba beíratom a SZUMHA függvényt, ennek az értékét másoltatom az F oszlopba.
Sub Gyomlal_1()
Dim sor%, usor%
usor% = Range("A1").End(xlDown).Row
'Adatok összefűzése az N oszlopba
Range("N1") = "Összefűzve"
Range("N2:N" & usor%) = "=A2&B2&C2&D2&E2&G2&H2&I2&J2&K2&L2"
'Irányított szűrés az U oszlopba
Range("N1:N" & usor%).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"U1"), Unique:=True
'M oszlopba FKERES-sel darabszám, AE-be SZUMHA függvény
Range("M1") = "Egyedi tétel"
For sor% = 2 To usor%
Range("M" & sor%) = Application.WorksheetFunction.VLookup(Range("N" & sor%), Range("U:AD"), 10, 0)
Cells(sor%, "AE").FormulaR1C1 = "=SUMIF(C[-17],RC[-17],C[-25])"
Next
Range("AE2:AE" & usor%).Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues
'Azonos sorok törlése
For sor% = usor% To 2 Step -1
If Application.CountIf(Range("N:N"), Range("N" & sor%)) > 1 Then _
Range("A" & sor% & ":M" & sor%).Delete shift:=xlUp
Next
'Segédoszlopok adatainak törlése
Columns("M:AE").ClearContents
End Sub -
-
Delila_1
veterán
-
Delila_1
veterán
válasz
#05304832
#14943
üzenetére
Ha jól értem, egy lapon van sok, változó számú sorod.
Az adatok az A:L tartományban vannak.
Előfordulnak teljesen megegyező sorok.
Ezeket kell kigyomlálni, hogy az azonosakból csak 1 maradjon, és a sorban feltüntetni, hogy a törlés előtt hány volt az egyes duplikált sorból.Sub Gyomlal()
Dim sor%, usor%, usor1%
usor% = Range("A1").End(xlDown).Row
'Adatok összefűzése az N oszlopba
Range("N1") = "Összefűzve"
Range("N2:N" & usor%) = "=A2&B2&C2&D2&E2&F2&G2&H2&I2&J2&K2&L2"
'Irányított szűrés az U oszlopba
Range("N1:N" & usor%).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"U1"), Unique:=True
usor1% = Range("U1").End(xlDown).Row 'U oszlop alsó sora
'AD oszlopba darabszám
Range("AD1") = "Db"
Range("AD2:AD" & usor1%).FormulaR1C1 = "=COUNTIF(R2C14:R" & usor% & "C14,RC[-9])"
'M oszlopba FKERES-sel darabszám
Range("M1") = "Egyedi tétel"
For sor% = 2 To usor%
Range("M" & sor%) = Application.WorksheetFunction.VLookup(Range("N" & sor%), Range("U:AD"), 10, 0)
Next
'Azonos sorok törlése
For sor% = usor% To 2 Step -1
If Application.CountIf(Range("N:N"), Range("N" & sor%)) > 1 Then _
Range("A" & sor% & ":M" & sor%) = ""
Next
'Segédoszlopok adatainak törlése
Columns("N:AE").ClearContents
End Sub -
Delila_1
veterán
válasz
CHANNIS
#14930
üzenetére
Átalakítottam.
Sub alma()
Dim sor%, tol%, ig%, usor%, nev$
Dim WS1 As Worksheet, WS2 As Worksheet
Set WS1 = Worksheets("Munka1")
Set WS2 = Worksheets("Munka2")
usor% = WS2.Range("I" & Rows.Count).End(xlUp).Row
For sor% = 3 To usor%
nev$ = WS2.Range("I" & sor%)
ig% = Application.WorksheetFunction.Match(nev$, WS1.Columns(2), 0)
tol% = ig%
Do While WS1.Cells(ig%, 2) = nev$
ig% = ig% + 1
Loop
WS1.Rows(ig%).EntireRow.Insert
WS1.Cells(ig%, "B") = WS2.Cells(sor%, "I")
WS1.Cells(ig%, "C") = WS2.Cells(sor%, "G")
WS1.Cells(ig%, "E") = WS2.Cells(sor%, "J")
WS1.Cells(ig%, "G") = WS2.Cells(sor%, "K")
WS1.Rows(ig% + 1).EntireRow.Insert
WS1.Rows(ig% + 2).EntireRow.Insert
Next
End Sub -
Delila_1
veterán
válasz
#05304832
#14914
üzenetére
Azt kérted, hogy ha a MÁSODIK sor valamelyik cellája egyezik a felsoroltakkal, akkor ne törölje az oszlopot. Te most az ELSŐ sorba írtad a címeket, a másodikban nem találhatóak ezek a nevek.
Vagy szúrj be 1 sort az első fölé, hogy a másodikba kerüljenek a nevek, vagy a makróban azIf Sheets("Sheet 1").Cells(2, oszlop%) = T(Tag%) Then sort írd át
If Sheets("Sheet 1").Cells(1, oszlop%) = T(Tag%) Then-re.
-
Delila_1
veterán
-
Delila_1
veterán
válasz
#05304832
#14907
üzenetére
Szia!
Sub Oszlopok()
Dim T, Tag%, f As Boolean
Dim oszlop%, uoszlop%
T = Array("LENX", "LENY", "LENZ", "MATERIAL", "NAME", "SUMMARY", "TIP", "A1", "A2", "B1", "B2", "HIV")
uoszlop% = Sheets("Sheet1").UsedRange.Columns.Count
For oszlop% = uoszlop% To 1 Step -1
f = False
For Tag% = 0 To 11
If Sheets("Sheet1").Cells(2, oszlop%) = T(Tag%) Then
f = True
Exit For
End If
Next
If f = False Then Columns(oszlop%).Delete shift:=xlToLeft
Next
End Sub -
Delila_1
veterán
válasz
CHANNIS
#14900
üzenetére
Tedd ki a füzetet egy elérhető helyre. Nincs időm újra beirkálni az adataidat egy másik helyre. Ha azonnal az igazi helyükkel teszed fel a kérdést, már kész lenne. A makrót az előzően betett képeken szereplő oszlopokhoz írtam meg. Nem értem, miért más helyekre kérdeztél rá, nem a valósra.
-
Delila_1
veterán
válasz
#05304832
#14894
üzenetére
A 14811-es kérdésed szerint több adatod van, amiknek megfelelően több oszlopot kell meghagyni. Erre a 14863-as választ kaptad. A válasz szerint a keresendő értékek az egyik-, a törlendő oszlopok a másik lapon helyezkednek el.
A 14888-ban egyetlen értéket (LEVEL) kerestetsz, erre a 14891-ben kaptál választ.
A 14892-ben azt írod, 1 lapod és több nem törlendő oszlopod van. Hol van a lapon a nem törlendők megnevezése? Pontatlan kérdésre nem lehet jó választ adni.
-
Delila_1
veterán
válasz
#05304832
#14892
üzenetére
Sub oszlop_torles()
Dim oszlop%, nev$
nev$ = "LEVEL"
For oszlop% = 36 To 1 Step -1
If Cells(2, oszlop%) <> nev$ Then Columns(oszlop%).Delete Shift:=xlToLeft
Next
End SubEzzel már nagyon gyorsan lefut majd. Benne felejtettem egy nem oda való ciklust az előzőből, mikor több címszóra kellett rákeresni, bocsi. Mentségemre, hogy el kell mennem, ezért kapkodok.
-
Delila_1
veterán
válasz
#05304832
#14888
üzenetére
Ha csak 1 lapról és 1 adatról van szó, elég ez:
Sub oszlop_torles()
Dim sor%, usor%, oszlop%, nev$
usor% = Application.WorksheetFunction.CountA(Columns(1))
For sor% = 1 To usor%
nev$ = "LEVEL"
For oszlop% = 36 To 1 Step -1
If Cells(2, oszlop%) <> nev$ Then Columns(oszlop%).Delete Shift:=xlToLeft
Next
Next
End Sub -
Delila_1
veterán
válasz
CHANNIS
#14882
üzenetére
Küldöm az ígért makrót. A lista1 nálam az első lapon van, a lista2 pedig a másodikon.
Ezt adom meg a két 'Set =' kezdetű sorban.Sub alma()
Dim sor%, tol%, ig%, usor%, nev$, aktual%
Dim WS1 As Worksheet, WS2 As Worksheet
Set WS1 = Worksheets(1)
Set WS2 = Worksheets(2)
usor% = WS2.Range("J" & Rows.Count).End(xlUp).Row
For sor% = 3 To usor%
nev$ = WS2.Range("J" & sor%)
aktual% = Application.WorksheetFunction.Match(nev$, WS1.Columns(2), 0)
tol% = aktual%
Do While WS1.Cells(aktual%, 2) = nev$
aktual% = aktual% + 1
Loop
ig% = aktual% - 1
WS1.Rows(ig% + 1).EntireRow.Insert
WS1.Cells(ig% + 1, 1) = WS1.Cells(ig%, 1)
WS1.Cells(ig% + 1, 2) = WS1.Cells(ig%, 2)
WS1.Cells(ig% + 1, 4) = WS2.Cells(sor%, "K")
WS1.Rows(ig% + 2).EntireRow.Insert
WS1.Rows(ig% + 3).EntireRow.Insert
WS1.Cells(tol%, 4) = "=SUM(D" & tol% + 1 & ":D" & ig% + 3 & ")"
Next
End Sub -
Delila_1
veterán
válasz
#05304832
#14875
üzenetére
Próba nélkül! átalakítottam az előbb küldött makrót.
Sub oszlop_torles()
Dim sor%, usor%, oszlop%, nev$
Dim WS1 As Worksheet, WS2 As WorksheetSet WS1 = Sheets("Keresendő")
Set WS2 = Sheets("Adatok")
usor% = Application.WorksheetFunction.CountA(WS1.Columns(1))For sor% = 1 To usor%
nev$ = WS1.Cells(sor%, "A")
For oszlop% = 36 To 1 Step -1
If WS2.Cells(2, oszlop%) <> nev$ Then Columns(oszlop%).Delete Shift:=xlToLeft
Next
Next
End SubSzerk.: Nem jelöltem programkódnak, utólag nem lehet javítani, de biztosan meg tudod csinálni. Ilyen pocsék formában is működnie kell.
-
Delila_1
veterán
válasz
#05304832
#14811
üzenetére
Nem pontos a kérdés felvetése, azért nem válaszoltam eddig rá.
Azt írod, az "A2 sorban keressen neveket ". Az A2 egy cella, nem egy sor.Írtam egy makrót. A füzetben a Keresendő lap A oszlopában vannak a nevek (NAME, SUMMARY, stb.), az Adatok lapon pedig az oszlopok. A makró kitörli azokat az oszlopokat, amiknek a 2. sorában szerepel valamelyik a felsorolt nevek közül. Ha ez jó, akkor megírom a másikat is. Ugyanazt a táblázatot kell így is, úgy is kigyomlálni? Az a cél, hogy az Adatok lapon minden sor és oszlop eltűnjön, amelyikben valamelyik szó szerepel a felsoroltak között?
Sub oszlop_torles()
Dim sor%, usor%, oszlop%, uoszlop%, nev$
Dim WS1 As Worksheet, WS2 As Worksheet
Set WS1 = Sheets("Keresendő")
Set WS2 = Sheets("Adatok")
usor% = Application.WorksheetFunction.CountA(WS1.Columns(1))
For sor% = 1 To usor%
nev$ = WS1.Cells(sor%, "A")
uoszlop% = WS2.Cells(2, 256).End(xlToLeft).Column
For oszlop% = uoszlop% To 1 Step -1
If WS2.Cells(2, oszlop%) = nev$ Then Columns(oszlop%).Delete Shift:=xlToLeft
Next
Next
End Sub
![;]](http://cdn.rios.hu/dl/s/v1.gif)
Új hozzászólás Aktív témák
Fferi50- Kaspersky, BitDefender, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.
- Fallout 4 Pip-Boy Edition eladó
- Microsoft és egyéb dobozos retro szoftverek
- Game Pass Ultimate előfizetések 1 - 36 hónapig azonnali kézbesítéssel a LEGOLCSÓBBAN! AKCIÓ!
- DOKKOLÓ BAZÁR! Lenovo, HP, DELL és egyéb más dokkolók (TELJES SZETTEK)
- Apple iPhone 16 Pro Max 256GB,Újszerű,Dobozaval,12 hónap garanciával
- Apple iPhone 13 128GB, Kártyafüggetlen, 1 Év Garanciával
- 210 - Lenovo IdeaPad 5 Pro (16ARH7) - AMD Ryzen 7 6800HS, RTX 3050Ti
- iPhone SE 2020 128GB Black -1 ÉV GARANCIA - Kártyafüggetlen, MS4594
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest