-
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
válasz
Mittu88
#28245
üzenetére
Ez a makró akkor fut hibára, ha az inputboxban olyan számot kap, ami nem szerepel az A oszlopban.
Nyilván át tudod alakítani a saját célodra.Sub hiba()
Dim lel, szam As Integer
Innen:
On Error GoTo 0
szam = Application.InputBox("Kérem az egész számot", "Szám bekérése", , , , , , 1)
lel = Application.Match(szam, Columns(1), 0)
If VarType(lel) = vbError Then
MsgBox "Újra!", vbExclamation
GoTo Innen
End If
MsgBox "A makró többi része"
End Sub -
#28260
Delila_1
veterán
schmiedpeter
#28247
Delila_1
veterán
válasz
schmiedpeter
#28247
üzenetére
A tartományt kijelölve a képlet
=vagy($b2="Szo";$b2="V")
-
#28257
Delila_1
veterán
coldfirexx
#28255
Delila_1
veterán
válasz
coldfirexx
#28255
üzenetére
Rögzíts egy makrót. Ebben annyi legyen, hogy autoszűrővel szűröd az AE oszlopot a szövegedre. Beállsz az első látható sor A cellájára, Ctrl+le nyíllal kijelölöd a látható tartományt, és törlöd a sorokat, majd az AE oszlopban megszünteted a szűrést.
Ez akkor jó, ha az A oszlopban is folyamatosan annyi adat van, mint az AE-ben.
A 2. kérdésedre, a formátum másolására:
Rows("2:2").Copy
Rows("3:3").Select
Range(Selection, Selection.End(xlDown)).PasteSpecial xlPasteFormats
Application.CutCopyMode = False -
#28238
Delila_1
veterán
coldfirexx
#28234
Delila_1
veterán
válasz
coldfirexx
#28234
üzenetére
Pl. így:
Sub Kepletek()
Dim usor1 As Long, usor2 As Long
usor1 = Range("A" & Rows.Count).End(xlUp).Row
usor2 = Range("Z" & Rows.Count).End(xlUp).Row
Range("Z" & usor2 & ":AM" & usor2).Copy
Range("Z" & usor2 + 1 & ":Z" & usor1).PasteSpecial xlPasteFormulas
Application.CutCopyMode = False
End Sub -
#28235
Delila_1
veterán
coldfirexx
#28234
Delila_1
veterán
válasz
coldfirexx
#28234
üzenetére
Nem kell ehhez makró, 1 (dupla) kattintással megvan.
Kijelölöd az eddigi utolsó képleteket (Z3:AM3 tartomány). A kijelölés jobb alsó sarkában van egy kis fekete négyzet, azon egy duplaklikk lemásolja a képleteket addig, amíg a mellette lévő Z oszlopban valamilyen értéket talál.
-
#28233
Delila_1
veterán
nyirisandor
#28232
Delila_1
veterán
válasz
nyirisandor
#28232
üzenetére
Valószínű, hogy azóta poffsoft már válaszolt privátban, de ha nem, ez is megteszi.
Mikor egy új nevet viszel be a B oszlopba, a jobb oldali táblázat automatikusan frissül.
Az A1:B1 és a D1:G1 tartományban megszüntettem a cellák összevonását. Javaslom, hogy ezután is kerüld ezt a formázási lehetőséget, mert elég sok galibát okozhat.
Egyenként jelöld ki a két tartományt, és a cellaformázásnál nézd meg a vízszintes elrendezés beállítását. -
#28228
Delila_1
veterán
coldfirexx
#28227
Delila_1
veterán
válasz
coldfirexx
#28227
üzenetére
Szívesen.
-
#28226
Delila_1
veterán
coldfirexx
#28225
Delila_1
veterán
válasz
coldfirexx
#28225
üzenetére
Az utolsó makrót másold be, azzal ott lesz szegély, ahol kell.
-
#28224
Delila_1
veterán
coldfirexx
#28223
Delila_1
veterán
válasz
coldfirexx
#28223
üzenetére
Sub Elrejt()
Dim szam As Long, CV As Range
For Each CV In Range("A39:A83")
If CV = "Elrejtve" Then
Rows(CV.Row).EntireRow.Hidden = True
Else
Rows(CV.Row).EntireRow.Hidden = False
szam = CV.Row
End If
Next
Range("B" & szam & ":N" & szam).Borders(xlEdgeTop).Weight = xlMedium
End SubAkkor az utolsó, nem rejtett sornak adunk felső szegélyt.
-
#28222
Delila_1
veterán
coldfirexx
#28221
Delila_1
veterán
válasz
coldfirexx
#28221
üzenetére
Sub Elrejt()
Dim szam As Long, CV As Range
For Each CV In Range("A39:A83")
If CV = "Elrejtve" Then
Rows(CV.Row).EntireRow.Hidden = True
Else
Rows(CV.Row).EntireRow.Hidden = False
End If
szam = CV.Row
Next
Range("B" & szam & ":N" & szam).Borders(xlEdgeBottom).Weight = xlMedium
End SubNem világos, hogy az alsó, látható adat, vagy az utolsó elrejtett sor aljára akarsz-e vastag vonalat?
Ha az utóbbi, akkor a szam = CV.Row sort az Else fölé tedd át. Ebben az esetben viszont nem látszik, mert ez a sor rejtett. -
#28220
Delila_1
veterán
coldfirexx
#28219
Delila_1
veterán
válasz
coldfirexx
#28219
üzenetére
Szívesen.
Set terulet=Range("A39:A83")
-
#28218
Delila_1
veterán
coldfirexx
#28217
Delila_1
veterán
válasz
coldfirexx
#28217
üzenetére
Sub Elrejt()
Dim terulet As Range, CV As Range
Set terulet = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
For Each CV In terulet
If CV = "Elrejtve" Then
Rows(CV.Row).EntireRow.Hidden = True
Else
Rows(CV.Row).EntireRow.Hidden = False
End If
Next
End SubTalán ez jó lesz.
-
#28216
Delila_1
veterán
nyirisandor
#28212
Delila_1
veterán
válasz
nyirisandor
#28212
üzenetére
A lapodhoz kell rendelned a makrót. Keress rá a laphoz rendelésre.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim usor As Long
If Target.Column = 2 And Target.Row > 2 And Target.Count = 1 Then
Application.EnableEvents = False
usor = Range("B" & Rows.Count).End(xlUp).Row
Range("B3:B" & usor).Copy Range("D3")
Range("E3:E" & usor).ClearContents
ActiveSheet.Range("$D$3:$D$" & usor).RemoveDuplicates Columns:=1, Header:=xlNo
usor = Range("D" & Rows.Count).End(xlUp).Row
Range("E3:E" & usor) = "=countif(B:B,D3)"
Application.EnableEvents = True
End If
End SubSzerk. Látom, már kaptál választ, míg én irkáltam.
Mikor új nevet viszel be a B oszlopba, a D és E oszlop felülíródik az új értékekkel.
-
#28200
Delila_1
veterán
the radish
#28199
Delila_1
veterán
válasz
the radish
#28199
üzenetére
Szívesen.
Én az elejére tettem.
-
#28198
Delila_1
veterán
the radish
#28197
Delila_1
veterán
válasz
the radish
#28197
üzenetére
Ki kellene ürítenie a lapot.
Legyen helyette WSM.Cells.ClearContents -
#28196
Delila_1
veterán
the radish
#28189
Delila_1
veterán
válasz
the radish
#28189
üzenetére
Sub masolas()
Dim tol, ig
Dim WSI As Worksheet, WSM As Worksheet
Dim sorszam 'az A oszlop értékei
Dim sorM As Long 'ahova másolsz
Set WSI = Workbooks("Innen masol.xlsm").Sheets("Innen_lap")
Set WSM = Workbooks("Masolat.xlsx").Sheets("Masolat_lap")
WSM.Cells = "" 'másolat lapjának kiürítése
WSI.Activate
Rows(1).Copy WSM.Range("A1") 'fejléc másolása
sorszam = 1: tol = 2
Do While Cells(tol, 1) <> ""
sorM = Application.CountA(WSM.Columns(1)) + 1 'ebbe a sorba kell másolni
tol = Application.Match(sorszam, Columns(1), 0)
If VarType(tol) = vbError Then 'ha nem talált tol értéket
MsgBox "Kesz"
Exit Sub
Else
ig = Application.Match(sorszam, Columns(1), 1)
Rows(tol & ":" & ig).Copy WSM.Range("A" & sorM)
Makro 'Itt indul a saját makród
sorszam = sorszam + 1 'növeljük a keresendő értéket
End If
Loop
End Sub
Sub Makro() 'ez a saját makród
MsgBox "Makró"
End Sub -
-
Delila_1
veterán
A VBE-ben beteszed egy modulba. Ugyanúgy alkalmazhatod, mint az Excel függvényeit. Az fx ikonra kattintva bejön a felhasználói kategóriában, de a billentyűzetről is beviheted.
Ha pl. az A1-ben van a kapcsos zárójelek nélküli útvonal és név, egy cellában erre hivatkozhatsz.
=filename(a1)
-
Delila_1
veterán
Saját függvénnyel megoldható.
Function Filename(nev As Range)
Dim bal As String, jobb As String, b As Integer
For b = Len(nev) To 1 Step -1
If Mid(nev, b, 1) <> "\" Then
jobb = Mid(nev, b, 1) & jobb
Else
Exit For
End If
Next
Filename = Left(nev, b) & "[" & jobb & "]"
End Function -
Delila_1
veterán
válasz
marcyman
#28121
üzenetére
Másold a lenti makrót a lapod kódlapjára (lapfülön jobb klikk, Kód megjelenítése, a jobb oldalon kapott üres részbe másold). Lépj vissza a füzetbe, és a G1 cellába írd be az utolsó sor számát, ahol a D oszlopban szám szerepel. A példád szerint ez 23.
Innen kezdve mikor a B oszlopba új adatot viszel be, a makró kiszámolja, hogy a jelzett cellák összege meghaladja-e a félmilliót. Ha nem, akkor a D oszlopba beírja az NT szöveget. Ellenkező esetben a maradékot, ahogy írtad, a G1-be beviszi az új sorszámot, az E oszlopban elvégzi a cellák összevonását, és beírja oda a következő sorszámot, a példa szerinti 209-et. beírja a C-be a B-D értéket.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim osszeg, sor As Long, tartomany As Range
If Target.Column = 2 And Target.Row > 2 And Target.Count = 1 And Target > "" Then
Application.EnableEvents = False
sor = Range("G1")
Set tartomany = Range("B" & sor + 1 & ":B" & Target.Row)
osszeg = Cells(sor, "D") + Application.WorksheetFunction.Sum(tartomany)
If osszeg >= 500000 Then
Range("D" & Target.Row) = osszeg - 500000
Range("G1") = Target.Row
Range("E" & sor + 1) = Application.WorksheetFunction.Max(Columns(5)) + 1
Range("E" & sor + 1 & ":E" & Target.Row).MergeCells = True
Range("E" & sor + 1 & ":E" & Target.Row).VerticalAlignment = xlCenter
Cells(Target.Row, "C") = Cells(Target.Row, "B") - Cells(Target.Row, "D")
Range("G1") = Target.Row
Else
Cells(Target.Row, "D") = "NT"
End If
Application.EnableEvents = True
End If
End Sub -
Delila_1
veterán
A lenti makróval megnyithatod az ismeretlen útvonalon lévő, ismeretlen nevű fájlodat.
Sub FileBehuzas()
Dim FD As Object, FN As String
Set FD = Application.FileDialog(3)
With FD
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
FN = ""
MsgBox "Nem választottál fájlt", vbExclamation
Exit Sub
Else
FN = .SelectedItems(1)
End If
End With
Workbooks.Open Filename:=FN
End Sub -
-
-
Delila_1
veterán
válasz
poffsoft
#28085
üzenetére
Egyszerűbb megoldás:
Sub mm()
Dim sor As Long, usor As Long
usor = Range("A" & Rows.Count).End(xlUp).Row
For sor = 5 To usor Step 29
Range("B" & sor & ":Z" & sor + 4).Delete Shift:=xlUp
Range("B" & sor + 20 & ":Z" & sor + 24).Insert Shift:=xlDown
Next
End SubMivel nem látszik a képen, melyik az utolsó felhasznált oszlop a táblázatban, Z-ig törlök, ill. szúrok be cellákat.
-
Delila_1
veterán
válasz
KubanitoS
#28070
üzenetére
Makró, amire poffsoft utalt:
Sub SorTorles()
Dim sor As Long, usor As Long
usor = Range("A" & Rows.Count).End(xlUp).Row
For sor = usor To 5 Step -1
If Application.WorksheetFunction.CountA(Rows(sor)) = 0 Then _
Rows(sor).Delete
Next
End SubA makró az A oszlopban található utolsó adattól indul felfelé. Ahol üres sort talál, azt kitörli, az első 5 sor kivételével.
Ha van oszlop, ahol több kitöltött sor van, mint az A oszlopban, az
usor = Range("A" & Rows.Count).End(xlUp).Row -ban írd át az A-t az oszlopod betűjelére.
A For kezdetű sorban írhatod át a meghagyandó felső sorok számát 5-ről.
Mivel nem tudom, minden lapodon kell-e ismételni a sorok törlését, 1 lapra írtam meg. Azon a lapon töröl, amelyiken éppen állsz. -
Delila_1
veterán
Makróval megoldható.
Sub Megis_makro()
Dim usor As Long, oszlop As Integer, uoszlop As Integer
Dim ter As Range, CV As Range
Sheets("Munka1").Activate
usor = ActiveSheet.UsedRange.Rows.Count '*
uoszlop = ActiveSheet.UsedRange.Columns.Count '**
Set ter = ActiveSheet.Range(Cells(2, "A"), Cells(usor, uoszlop)) '***
oszlop = 1
For Each CV In ter
If CV > "" Then
Sheets("Munka2").Cells(CV.Row, oszlop) = CV
oszlop = oszlop + 1
End If
If CV.Column = uoszlop Then oszlop = 1
Next
End SubHárom sor végére csillagokat tettem. Ha a Munka1 lapon (ahol az eredeti adatok vannak) meghatározott területről kell kigyűjtened a Munka2 lapra az adatokat, az 1 és 2 csillagos sort töröld ki, a 3 csillagos helyett pedig ez legyen:
Set ter =Range("A2:F5"), de persze az F5 helyére a saját területed jobb alsó cellájának a címe kerüljön.
A Munka1 és Munka2 lapok nevét is írd át a saját lapjaid nevére.
-
-
Delila_1
veterán
Akkor ez most részemről sajnos nem jött össze. Hétfőtől 1,5 hétig nem leszek gép közelében.
Az egyes lapokon viszont tudod indítani a rögzítettet. A makróban a következő lapoknál futtatás előtt a Kimutatás1-et kell minden előfordulásánál átírnod a következő számra (Kimutatás2 ... Kimutatás_sok). Legjobb, ha a Replace funkcióval hajtod végre, hogy ne maradjon ki egy sem.
Az
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"24!R1C1:R1048576C13", Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:="24!R1C14", TableName:="Kimutatás1", DefaultVersion:= _
xlPivotTableVersion14
Sheets("24").Selectrészben a 24-et is át kell írnod a következő lapok nevére, 3× fordul itt elő.
Azt hiszem, mást nem kell módosítani, mivel a teljes oszlopokat jelölted ki a táblázatodban, nem szorosan az adatokat tartalmazó részt.Mikor létrehoztad a 2. kimutatást a fent írt változtatások bevitele után, megnézed, rendben van-e. Ha nem, mentés nélkül zárd be a füzetet. Ebben az esetben biztosan lesz, aki segít.
-
Delila_1
veterán
Igen, megoldható.
Rögzíts egy makrót, amin előállítod 1 lapon a kimutatást, majd ezt másold be ide a topikba.
Írd meg, hány lapon kell ezt megismételni, ezek a lapok egymás után vannak-e, vagy van közöttük olyan, ahol nem kell kimutatás.Az is számít, hogy az egyes lapokon azonos sorszámú-e az A:M tartomány, vagy le kell majd kérdezni az utolsó sort.
-
-
#27850
Delila_1
veterán
INTELligent
#27849
Delila_1
veterán
válasz
INTELligent
#27849
üzenetére
Eszerint sikerült összehozni.
Szívesen.
-
#27848
Delila_1
veterán
INTELligent
#27847
Delila_1
veterán
válasz
INTELligent
#27847
üzenetére
Nem kell hozzá makró. Nézd meg az autoszűrő szín szerinti szűrését, és a RÉSZÖSSZEG függvényt.
Utóbbit olyan cellába írd, ami nem játszik bele az összegzésbe. Ha pl. a G oszlopot akarod szummázni, akkor ne a G1-ben legyen a függvény.
-
#27845
Delila_1
veterán
JamesHolden
#27833
Delila_1
veterán
válasz
JamesHolden
#27833
üzenetére
Add meg, melyik elem kiválasztásakor milyen szöveg jelenjen meg.
-
#27840
Delila_1
veterán
JamesHolden
#27839
Delila_1
veterán
válasz
JamesHolden
#27839
üzenetére
Ha csak pár sornál kell, ezeknél a soroknál add meg a figyelmeztető szöveget, a többinél ne.
-
#27834
Delila_1
veterán
JamesHolden
#27833
Delila_1
veterán
válasz
JamesHolden
#27833
üzenetére
Az érvényesítés párbeszédablakának 2. fülén beállíthatod a megjelenő figyelmeztető szöveget.
-
-
Delila_1
veterán
-
Delila_1
veterán
válasz
Hege1234
#27785
üzenetére
Most igen, előbb volt kép.
A mostaniból tudtam meg, hogy az F és G oszlopokban képletek vannak, és ezek törteket adnak eredményül.
A kigyűjtésben a DARABTELI függvény kritériumába egész számot írtunk, hát persze, hogy nem talált megfelelőt.A könnyebb utat választottam. Felvettem 2 segédoszlopot. Az elsőben (H) nullát íratok oda, ahol az F és G is üres(nek látszik), ahol pedig az F-ben érték van, oda a kerekített értékét íratom. Ebben az oszlopban számol a K:L tábla.
Az I oszlop a G értékeit kerekíti, ezt az N:O számlálja össze. -
-
Delila_1
veterán
A lenti makró az A1 cellában lévő rajzszámhoz tartozó képhez készít hiperlinket a B1 cellába. A makróban kell megadni az elérési útvonalat, és a kép kiterjesztését.
Sub rajz()
Dim utvonal As String
utvonal = "F:\jpg\Fotó\" 'ide kell a saját útvonalad
ActiveSheet.Hyperlinks.Add Anchor:=Range("B1"), Address:= _
utvonal & Range("A1").Value & ".jpg", TextToDisplay:=Range("A1").Value
End SubAhhoz, hogy az összes rajzszámhoz beírhassuk a hiperlinket, meg kell adnod, melyik oszlopban vannak a rajzszámok, melyik oszlopba kéred a hiperlinket.
Az is fontos, hogy a rajzszámos oszlop hányadik sorában kezdődnek a számok, és hogy vannak-e olyan sorok, amikben nincs rajzszám. -
Delila_1
veterán
válasz
Hege1234
#27760
üzenetére
Felvettem egy segédoszlopot, a H-t. Itt nullát ad, ha az F és G is üres. A zöld hátterű oszlop helyett ebben számoltatom össze az egyes értékek előfordulásának a darabszámát a J és K oszlopban. A pirosakat az M és N számolja meg.
A K3 és M3, valamint a H2 képletét lemásoltam az alattuk lévő sorokba.
Remélem, kifér a kép teljes egészében.
-
-
Delila_1
veterán
válasz
RedHarlow
#27748
üzenetére
A makró az U oszlopba írja ki a nevet és a jogosultságot.
Sub Jogosultsag()
Dim sor As Long, usor As Long, oszlop As Integer
usor = Range("A" & Rows.Count).End(xlUp).Row
For sor = 2 To usor
Cells(sor, "U") = "[" & Cells(sor, "A") & "] "
For oszlop = 7 To 20
If Cells(sor, oszlop) = "true" Then
Cells(sor, "U") = Cells(sor, "U") & "[" & Cells(1, oszlop) & "] "
End If
Next
Next
End Sub
Új hozzászólás Aktív témák
- OpenWRT topic
- ThinkPad (NEM IdeaPad)
- TGA2025 - Lara Croft felbukkanása már szinte borítékolt
- Kerékpárosok, bringások ide!
- Milyen videókártyát?
- Csak egy ország kap Exynos 2600-as Galaxy S26 telefonokat?
- A fociról könnyedén, egy baráti társaságban
- Pánik a memóriapiacon
- Házimozi belépő szinten
- Spórolós topik
- További aktív témák...
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Bitdefender Total Security 3év/3eszköz! - Tökéletes védelem, Most Ünnepi áron! :)
- Eladó Steam kulcsok kedvező áron!
- Game Pass Ultimate előfizetések 1 - 36 hónapig azonnali kézbesítéssel a LEGOLCSÓBBAN! AKCIÓ!
- Kaspersky, BitDefender, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- BESZÁMÍTÁS! ASUS H510M i5 10400F 16GB DDR4 512GB SSD GTX 1060 6GB Rampage SHIVA DEEPCOOL 400W
- Telefon felvásárlás!! Samsung Galaxy A20e/Samsung Galaxy A40/Samsung Galaxy A04s/Samsung Galaxy A03s
- Apple iPhone 14 Pro Max / Kártyafüggetlen / 256GB / 12Hó Garancia / 87% akku
- Surface Pro 7+ i5-1135G7 16G 256GB 1 év garancia
- Xiaomi Redmi 13 4G 256GB, Kártyafüggetlen, 1 Év Garanciával
Állásajánlatok
Cég: BroadBit Hungary Kft.
Város: Budakeszi
Cég: ATW Internet Kft.
Város: Budapest