-
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
-
#44763
Delila_1
veterán
Norbika1493
#44762
Delila_1
veterán
válasz
Norbika1493
#44762
üzenetére
Az A füzetben szűrd az adatokat úgy, hogy az üres sorok ne jelenjenek meg. Másold a látható sorokat, és illeszd be a B füzetbe.
-
Delila_1
veterán
válasz
jackal79
#44702
üzenetére
Jelöld ki az adataidat, de csak a jelenleg adatokat tartalmazó cellákat, tehát
A1:L123-ig. Beszúrás menü, Táblázat, jelöld be a Fejléceket tartalmazó táblázat opciót. Az adatokat nem tartalmazó teljes sorokat (124:1000) töröld.
MOST vidd be az érvényesítéseket, akár névvel hivatkozva a tartományokra, ahogy FFeri javasolta.
Több nagy előnye van ennek a módszernek. Új sor felvitelekor a fölötte lévő érvényesítéseket, formázásokat, képleteket örökli az új sor, nem terheli a fájlt a túlzott képletezés, formázás. Jelenleg oszloponként bő 8-szoros a képletek, érvényesítések száma (1000/123).
Bármelyik sorban átírsz egy képletet, a teljes oszlopra igaz lesz.
Ha kimutatást készítesz a táblázatból, nem kell átírnod a tartományt a megnövelt sorszámra, csak egy frissítést adsz a kimutatásra. -
Delila_1
veterán
-
Delila_1
veterán
válasz
Fferi50
#44634
üzenetére
A módosítás időpontja is lekérdezhető. Ímé pár adat lekérdezése:
Sub info()
Dim fn, size, crdat, uhf, um, fs, lapn
fn = ThisWorkbook.FullName
lapn = ActiveSheet.Name
Set fs = CreateObject("Scripting.FileSystemObject")
Set fn = fs.GetFILE(fn)
size = Format(fn.size, "# ##0")
crdat = fn.DateCreated
uhf = fn.DateLastAccessed
um = fn.DateLastModified
With Sheets(lapn)
.Cells(1, 1) = "Útvonal, név: " & fn
.Cells(2, 1) = "Méret: " & size / 1024 & " KB (" & size & " bájt)"
.Cells(3, 1) = "Létrehozva: " & crdat
.Cells(4, 1) = "Utolsó hozzáférés: " & uhf
.Cells(5, 1) = "Utolsó módosítás: " & um
End With
End Sub -
Delila_1
veterán
válasz
lrobertoc
#44609
üzenetére
A Munka1 laphoz rendeld a makrót.
Írd be a nevet (ha még nincs) az A oszlopba. Mikor beírtál egy adatot valamelyik hónaphoz, adj duplaklikket rá.Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim ide As Long, oszlop As Variant
If Target.Row > 1 And Target.Column > 1 Then
With Sheets("Munka2")
ide = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Cells(ide, 1) = Cells(Target.Row, 1) 'név
oszlop = Application.Match(Target.Column, .Rows(1), 0)
.Cells(ide, 2) = Cells(1, Target.Column) 'hónap neve
.Cells(ide, 3) = Target 'érték
End With
Cancel = True
End If
End Sub -
-
Delila_1
veterán
válasz
Morphy
#44598
üzenetére
Ahogy FFeri is írta, elég gyalázatos az Excel dátum-kezelése.
Próbáld meg, hogy szélesre veszed az oszlopot, akkor a dátumok jobbra igazítva jelennek meg, az esetleges szövegként megadottak balra.Összeállítottam egy ilyen vegyes (A) oszlopot, majd egy (B) segédoszlopban felszoroztam 1-gyel minden tagját. Érdekes módon a szövegeseket is számmá alakította a szorzás, és a B oszlop dátumkénti formázása valódi dátumot csinált mindegyikből. A szűrés is megfelelően működött.
-
Delila_1
veterán
válasz
zsolti_20
#44578
üzenetére
Nem volt pontos a leírás a 2. feladatnál. Ha az első lapról azokat a sorokat kell törölnöd, ahol az A oszlop értéke megtalálható a második lap A oszlopában, akkor a lenti makró megoldja.
Sub KettesFeladat()
Dim sor As Long, usor As Long
usor = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For sor = usor To 1 Step -1
If Application.WorksheetFunction.CountIf(Sheets("Sheet2").Columns(1), Sheets("Sheet1").Cells(sor, 1)) > 0 Then
Sheets("Sheet1").Rows(sor).Delete
End If
Next
End Sub -
Delila_1
veterán
válasz
marksz1
#44522
üzenetére
Vannak ún. volatilis függvények, amik ha a füzetben bármi változás van (beírás, törlés), frissülnek. Ezeket lehetőség szerint kerülni kell, más megoldással.
Ilyenek pl. a most, ma, rand, randbetween, vél, ofszet, indirekt, info, cella (attól függően, mi a tartalma), véletlen.között.
Az indirekt helyett érdemes az index - hol.van párost alkalmazni. -
#44415
Delila_1
veterán
Csokishurka
#44412
Delila_1
veterán
válasz
Csokishurka
#44412
üzenetére
Sub Utvonal_Csere()
Dim utvonalRegi As String, utvonalUj As String
utvonalRegi = Application.InputBox("Add meg a cserélendő útvonalat", "Régi útvonal bekérése", , , , , , 2)
utvonalUj = Application.InputBox("Add meg az új útvonalat", "új útvonal bekérése", , , , , , 2)
Application.DisplayAlerts = False
Cells.Replace What:=utvonalRegi, Replacement:=utvonalUj, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Application.DisplayAlerts = True
End Sub -
#44371
Delila_1
veterán
Csokishurka
#44370
Delila_1
veterán
válasz
Csokishurka
#44370
üzenetére
A Csere funkcióval egy lépésben kicserélheted a hivatkozásokban az elérési útvonalat.
-
Delila_1
veterán
válasz
bela85
#44350
üzenetére
Az újonnan beírt adatok felülírják a már ott lévőket.
Ha képletek vannak a Munka2 lap B oszlopában, akkor valóban értéket kell beilleszteni a Munka1-re.
Ez változik:
Do While .Range("B" & sor) <> ""
.Range("B" & sor).Copy
Sheets("Munka1").Range("B3").PasteSpecial xlPasteValues
ActiveWindow.SelectedSheets.PrintOut Copies:=1
sor = sor + 1
Loop -
Delila_1
veterán
válasz
bela85
#44348
üzenetére
Modulba tedd a makrót.
Sub Nyomtatas()
Dim sor As Long
sor = 2
Sheets("Munka1").Select
With Sheets("Munka2")
Do While .Range("B" & sor) <> ""
Sheets("Munka1").Range("B3") = .Range("B" & sor)
ActiveWindow.SelectedSheets.PrintOut Copies:=1
sor = sor + 1
Loop
End With
End Sub -
Delila_1
veterán
válasz
Fferi50
#44332
üzenetére
Ha már tapasztalat, és ismétlődések eltávolítása, megosztom egy rossz tapasztalatomat.
Pár napja egy 4000 soros, dátumokat tartalmazó oszlopnál merült fel egy súlyos probléma. Az egyedi értékek mellé SZUMHA függvényekkel két oszlop összegeit rendeltem az eredeti táblából. Az eredeti, és a képlettel kiszámolt összegek nem egyeztek meg.
Sok kínlódás után kiderült, hogy a kigyomlált oszlopban 2 dátum kétszer szerepelt.
Ezután az eredeti táblában az azonos dátumokat Ctrl+Enterrel vittem be, hogy azonosak legyenek. Az egyik párosnál sikerült, már csak egyszer szerepelt a kigyűjtöttben, de a másiknál nem. Annál 11 tétel volt az eredeti táblában.
Végül úgy oldottam meg, hogy DARABTELI függvénnyel a kigyűjtöttek mellé írattam az előfordulások számát, majd makróval eltüntettem a duplikációt.Lehet, hogy bizonyos számú ismétlődést nem tud kezelni a menüpont.
-
Delila_1
veterán
válasz
Sprite75
#44323
üzenetére
"Az lenne az igazi, ha nem is kellen gombot beraknom ennek a makrónak, hanem amikor írják be az adatokat az új sor gomb megnyomása uttán, és elérnek az adott sor Q oszlopába, és oda bekerül egy szám, akkor iródjon be a következő sorszám az adott sor D oszlopába."
Ehhez írtam az eseményvezérelt makrót.
-
Delila_1
veterán
válasz
Sprite75
#44321
üzenetére
Rendeld a laphoz:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 17 And Target.Row > 1 And Target.Count = 1 And Target <> "" Then
Cells(Target.Row, 4) = Application.WorksheetFunction.Max(Range("D2:D" & Target.Row - 1)) + 1
End If
End SubA feltételnél azt vizsgáljuk, hogy
– a Q oszlopról van-e szó,
– hogy legalább a 2. sor legyen a bevitel helye,
– ne törlés legyen,
– és van-e bevitt adat. Ehelyett írhatsz szám ellenőrzést:IsNumeric(Target)Nincs szükség az alsó sor helyére, mert a Q oszlop bevitelére reagál.
-
Delila_1
veterán
A kettes lapon lévő tartománynak nevet adsz. Legyen ez pl. Lista.
Az egyes lapon a tartománynak feltételes formázást adsz, a képlet=HOL.VAN(A2;Lista;0)Vagy képletet írsz az egyes lapon a B oszlopba.
=HA(HOL.VAN(A2;Lista;0);1)
A fellelhető értékek mellé 1-et ír, a többihez #HIÁNYZIK szöveget. Biztosan lehetne szépíteni, de most szaladok. -
#44260
Delila_1
veterán
zsoltzsolt
#44259
Delila_1
veterán
válasz
zsoltzsolt
#44259
üzenetére
Modulba tedd.
Az aktív cella fölé szúr be 59.000 sort.Sub Sorbeszuras()
Rows(Selection.Row & ":" & Selection.Row + 59000).EntireRow.Insert
End Sub -
Delila_1
veterán
FFeri ötlete szerint a DARABTELI függvényt minden lapon ugyanabba a cellába írd be.
Legyen ez a példában a B20.
Az összesítő lapon a 3 lap (KHT, XY, és Harmadik) lapon egy cellában 1 db képlettel összesítheted.=SZUM(KHT:Harmadik!B20)
Az első, és az utolsó lap nevét kell megadnod az összegzéshez. -
Delila_1
veterán
válasz
benjoe1
#44199
üzenetére
Makróval megoldható.
Első oszlop projektek, másodikba ír a makró, 3-tól az első sorban vannak a hetek.
A makrót modulba tedd, a füzetet makróbarátként kell mentened.Sub Heti_Arbevetel()
Dim oszlop As Integer, uoszlop As Integer, sor As Long
Columns("B:B") = ""
Range("B1") = "Tervezett" & vbLf & "árbevételek"
sor = 2: uoszlop = Cells(1, Columns.Count).End(xlToLeft).Column
Do While Cells(sor, 1) <> ""
For oszlop = 3 To uoszlop
If Cells(sor, oszlop) > "" Then Cells(sor, 2) = Cells(sor, 2) & Cells(1, oszlop) & ", "
Next
If Len(Cells(sor, 2)) > 0 Then Cells(sor, 2) = Left(Cells(sor, 2), Len(Cells(sor, 2)) - 2)
sor = sor + 1
Loop
Columns("B:B").EntireColumn.AutoFit
End Sub -
-
-
Delila_1
veterán
Semmi gond, 1-2 hét alatt sikerül összehoznod a kérdést.
Igen, minden 4-est írj át 2-re.
Nem nekem könnyebb – bár ez is lehet(ne) szempont –, hanem jóval terjedelmesebb lenne a makró, és a futása is hosszabb időt venne igénybe, ha nem a számot tartalmazó oszlopot töltenéd ki először. -
Delila_1
veterán
Mi a bevitel menete?
Beírod a számot a D oszlopba, majd színezed aG:Ioszlopokat?Legjobb lenne, ha a 3 cella színezését adnád meg először, majd beírnád a D oszlopba az értéket. Ebben az esetben a D oszlopba írást figyeltethetném. Amint beírod az értéket, arra a sorra lefutna a színezés.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sor As Long
If Target.Row > 2 And Target.Column = 4 Then
sor = Target.Row
If Cells(sor, 7).Interior.Color = vbGreen And Cells(sor, 8).Interior.Color = vbGreen And _
Cells(sor, 9).Interior.Color = vbGreen Then
Cells(sor, 4).Interior.Color = vbGreen
Else
Cells(sor, 4).Interior.Color = RGB(255, 198, 83)
End If
End If
End Sub -
Delila_1
veterán
Megírtam. A makrót modulba tedd, a füzetedben tegyél ki egy gombot, ahhoz rendeld a makrót.
Nem mindegy, hogy milyen zöld a G-H-I oszlop zöldje. A cellák színezésénél a További színeknél az Egyéni fülön legyen az R és B nulla, a G 255.Sub Zold_Narancs()
Dim sor As Long
sor = 3
Do While Cells(sor, "D") <> ""
If Cells(sor, "G").Interior.Color = vbGreen And Cells(sor, "H").Interior.Color = vbGreen _
And Cells(sor, "I").Interior.Color = vbGreen Then
Cells(sor, "D").Interior.Color = vbGreen
Else
Cells(sor, "D").Interior.Color = RGB(255, 198, 83)
End If
sor = sor + 1
Loop
End Sub -
Delila_1
veterán
-
-
Delila_1
veterán
Ezt egy modulba másold, és indíthatod, amikor ki akarod színezni az A4 cella hátterét.
Sub Zold_Narancs()
If Range("A1").Interior.Color = vbGreen And Range("A2").Interior.Color = vbGreen And _
Range("A3").Interior.Color = vbGreen Then
Range("A4").Interior.Color = vbGreen
Else
Range("A4").Interior.Color = RGB(255, 198, 83)
End If
End SubAutomatizálhatod, ha a laphoz rendeled a lenti makrót.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("A1").Interior.Color = vbGreen And Range("A2").Interior.Color = vbGreen And _
Range("A3").Interior.Color = vbGreen Then
Range("A4").Interior.Color = vbGreen
Else
Range("A4").Interior.Color = RGB(255, 198, 83)
End If
End SubHa viszont az
A1:A3tartományt feltételes formázással színezed, más a helyzet. Akkor az A4 cellába is feltételes formázás kell. -
Delila_1
veterán
válasz
cortez25
#43967
üzenetére
Az Excelben az idő alapegysége a nap.
A 60,24 percet elosztod 60-nal, így órában kapod meg az értéket, majd ezt osztod 24-gyel, hogy napban kapd meg. Ez az érték 0,041833, ami óó:pp formátumban 1:00A másik értéked (3614,6) másodperben van megadva, ezért osztod 60-nal, hogy perc legyen, majd újra 60-nal, hogy óra, végül 24-gyel, hogy napban legyen az értéked. Ennek az osztásnak az értéke 0,04183565. A fenti formátum szintén 1:00-t mutat.
-
#43935
Delila_1
veterán
dreizwanzig
#43933
Delila_1
veterán
válasz
dreizwanzig
#43933
üzenetére
Szívesen, harkhonnak is.
-
#43924
Delila_1
veterán
dreizwanzig
#43923
Delila_1
veterán
válasz
dreizwanzig
#43923
üzenetére
A feltételes formázás képlete az A oszlopban (A1-től kijelölve ameddig kell)
=$B1="x" -
Delila_1
veterán
válasz
p5quser
#43916
üzenetére
Nem kell a 11-es címke, hiszen nem irányít ide a makródban semmi.
A képletek beírásaIf ComboBox1 = "valami" Then
Range("D2:D31").FormulaR1C1 = _
"=(IFERROR(VLOOKUP(RC[-3],cikkek!C[-3]:C[5],R1C7,0),0))*R5C8"
Else
Range("D2:D31").FormulaR1C1 = _
"=(IFERROR(VLOOKUP(RC[-3],cikkek!C[-3]:C[5],R1C7,0),0))*R5C8*1.27"
End If -
Delila_1
veterán
válasz
Delila_1
#43848
üzenetére
Hopsza! Kimaradt az évenkénti összegző oszlop.
Sub Ev_Elrendezes()
Dim evek As Integer, honapok As Integer, ev As Integer, honap As Integer
Dim kezdoev As Integer, oszlop As Integer
kezdoev = Application.InputBox("Add meg a kezdő évet", "Év bekérése", , , , , , 2)
evek = Year(Date) - kezdoev + 1
oszlop = 1
For ev = 1 To evek
Cells(1, oszlop) = kezdoev
Range(Cells(1, oszlop), Cells(1, oszlop + 11)).HorizontalAlignment = xlCenterAcrossSelection
For honap = 1 To 12
Cells(2, oszlop) = honap
oszlop = oszlop + 1
Next
Cells(1, oszlop) = kezdoev & Chr(10) & "Összesen"
kezdoev = kezdoev + 1
oszlop = oszlop + 1
Next
End Sub -
Delila_1
veterán
A makró bekéri a kezdő évet, majd ennek megfelelően az első sorba beírja az éveket, a másodikba a hónapokat. Az évek a hozzájuk tartozó 12 hónap közepén látszanak, bár mindig az első hónap fölötti cellában vannak.
Sub Ev_Elrendezes()
Dim evek As Integer, honapok As Integer, ev As Integer, honap As Integer
Dim kezdoev As Integer, oszlop As Integer
kezdoev = Application.InputBox("Add meg a kezdő évet", "Év bekérése", , , , , , 2)
evek = Year(Date) - kezdoev + 1
oszlop = 1
For ev = 1 To evek
Cells(1, oszlop) = kezdoev
Range(Cells(1, oszlop), Cells(1, oszlop + 11)).HorizontalAlignment = xlCenterAcrossSelection
For honap = 1 To 12
Cells(2, oszlop) = honap
oszlop = oszlop + 1
Next
kezdoev = kezdoev + 1
Next
End Sub -
Delila_1
veterán
válasz
commanDOS
#43837
üzenetére
Írtam hozzá egy makrót. A 6 lap az első helyen legyen, és vegyél fel egy új lapot Összegző névvel, vagy írd át a makróban ezt a nevet.
Ha az egyes lapokon foglalt az AA oszlop, akkor a makróban 3 helyen (csillagokkal jelöltem) írd át az oszlop betűjelét olyanra, ahol biztosan nincs egyik lapodon sem adat.Az egyes lapokról az Összegző lapra egymás alá másolja a tartalmukat, közöttük egy sorral, ahol az első, A oszlop annak a lapnak a nevét tartalmazza, ahonnan az adatok származnak. Üres sorok itt már nem lesznek.
Sub Osszegzes()
Dim lap As Integer, ide As Long, usor As Long, sor As Long
Sheets("Összegző").Cells = ""
Sheets(1).Rows(1).Copy Sheets("Összegző").Range("A1")
For lap = 1 To 6
ide = Sheets("Összegző").Range("A" & Rows.Count).End(xlUp).Row + 1
usor = Sheets(lap).Range("A" & Rows.Count).End(xlUp).Row
Sheets(lap).Rows("2:" & usor).Copy Sheets("Összegző").Range("A" & ide)
Sheets("Összegző").Cells(ide, "AA") = Sheets(lap).Name '***
Next
With Sheets("Összegző")
usor = .Range("A" & Rows.Count).End(xlUp).Row
For sor = usor To 2 Step -1
If Application.WorksheetFunction.CountA(.Rows(sor)) = 0 Then .Rows(sor & ":" & sor).Delete
If .Cells(sor, "AA") > "" Then '***
Rows(sor).Insert
.Cells(sor, 1) = Cells(sor + 1, "AA") '***
End If
Next
.Columns("AA").Delete
End With
End Sub
Új hozzászólás Aktív témák
Hirdetés
- Intel Core i5 / i7 / i9 "Alder Lake-Raptor Lake/Refresh" (LGA1700)
- Kertészet, mezőgazdaság topik
- NVIDIA GeForce RTX 5080 / 5090 (GB203 / 202)
- Viccrovat
- Bestbuy játékok
- Továbbfejlődött a Keychron egéralternatívája a Logitech MX Masterre
- Gaming notebook topik
- Proxmox VE
- Házimozi haladó szinten
- PlayStation 1 / 2
- További aktív témák...
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Microsoft licencek KIVÉTELES ÁRON AZONNAL - UTALÁSSAL IS AUTOMATIKUS KÉZBESÍTÉS - Windows és Office
- Bontatlan - BATTLEFIELD 1 Collectors Edition - Játékszoftver nélkül
- Assassin's Creed Shadows Collector's Edition PC
- Bomba ár! Dell Latitude E5550 - i5-5GEN I 8GB I 128GB SSD I 15,6" FHD I W10 I HDMI I Cam I Gari!
- AKCIÓ! ASUS Z97-A Z97 chipset alaplap garanciával hibátlan működéssel
- ÁRGARANCIA! Épített KomPhone Intel i9 14900KF 32/64GB RAM RTX 5070 12GB GAMER PC termékbeszámítással
- Csere-Beszámítás! Xbox One X 1TB Játékkonzol Olvass! Model 1787
- Telefon felvásárlás!! Xiaomi Redmi Note 13, Xiaomi Redmi Note 13 Pro, Xiaomi Redmi Note 13 Pro+
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest