Hirdetés
- Mobil flották
- Távozik az Apple vezérigazgatója
- Okosóra és okoskiegészítő topik
- Vivo X300 Pro – messzebbre lát, mint ameddig bírja
- Motorola Edge 50 Fusion - jó fogás
- Nagy aksival és erős hardverrel megjött Magyarországra a Poco X8 Pro és Pro Max
- Fotók, videók mobillal
- iPhone topik
- Android alkalmazások - szoftver kibeszélő topik
- MWC 2026: Bajnoki címre pályázik a Xiaomi Watch 5
-
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
-
Delila_1
veterán
válasz
Bishop1
#16858
üzenetére
Figyelmesebben átolvasva azt szeretnéd, ha az új, dátum nevű lapokon a"t "lap címsora (A1:D1 tartomány) jelenne meg a második sorban, az A1 cellában pedig a dátum. Ha jól értem, nincs szükség az autoszűrő ki-bekapcsolására, csak a felső sort kell másolni.
Javaslom, hogy a bővítménykezelőben kapcsold be az Analysis ToolPak és az Analysis ToolPak -VBA bővítményeket, mert valószínű, hogy ezeknek a hiánya miatt futott hibára az előző verzió. Ezekkel kapsz egy halom hasznos új függvényt.
Sub Gomb80_Kattintás()
Dim lap As Integer, szam, ujnev
Sheets(1).Select
lap = Worksheets.Count
If Left(Sheets(lap).Name, 10) = CDate(Date) And Len(Sheets(lap).Name) > 11 Then
szam = Right(Sheets(lap).Name, Len(Sheets(lap).Name) - 12)
ujnev = szam + 1
Sheets.Add After:=Sheets(lap)
ActiveSheet.Name = Date & "_" & ujnev
Else
Sheets.Add After:=Sheets(lap)
ActiveSheet.Name = Date & "_1"
End If
Sheets("t").Range("A1:D1").Copy Sheets(lap + 1).Range("A2")
Sheets(lap + 1).Select
Range("A1") = Date
Columns("A:A").ColumnWidth = 24
Sheets("napi").Select
End Sub -
Bishop1
tag
válasz
Bishop1
#16858
üzenetére
Erre jutottam végül kis segítséggel, de ez nem számlálja az oldalakat, vagyis ha aznap még egy munkalapot nyitnék akkor hibaüzenetet ad az azonos munkalap nevek miatt. Ezt továbbgondolva, mi a módja hogy ha ilyenkor nyitáskor azonos munkalap nevet talál felülírja a frissebbel?
Sub Gomb80_Kattintás()
'
' Gomb80_Kattintás Makró
'
'
Sheets("t").Select
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$66").AutoFilter Field:=3, Criteria1:="<>"
Selection.Copy
Sheets.Add(After:=Worksheets(Sheets.Count)).Name = Date
Columns("A:A").ColumnWidth = 24
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "2/23/2013"
Sheets("t").Select
Selection.AutoFilter
Sheets("napi").Select
Range("O8").Select
End Sub -
Delila_1
veterán
válasz
Bishop1
#16852
üzenetére
Második kérdés. A Gyűjtő nevű lap C:D oszlopába gyűjti ki a 20-szal kezdődő nevű napok C1:D1 cellájának az adatait.
Sub C1D1()
Dim usor As Integer, lap As Integer
For lap = 1 To Worksheets.Count
If Left(Sheets(lap).Name, 2) = "20" Then
usor = Sheets("Gyűjtő").Cells(Rows.Count, "C").End(xlUp).Row + 1
Sheets(lap).Range("C1:D1").Copy Sheets("Gyűjtő").Range("C" & usor)
End If
Next
End Sub -
Delila_1
veterán
válasz
Bishop1
#16852
üzenetére
Az első kérdésre a makró:
Sub Gomb80_Kattintás()
Dim lap As Integer, szam, ujnev
Sheets(1).Select
lap = Worksheets.Count
If Left(Sheets(lap).Name, 10) = CDate(Date) And Len(Sheets(lap).Name) > 11 Then
szam = Right(Sheets(lap).Name, Len(Sheets(lap).Name) - 12)
ujnev = szam + 1
Sheets.Add After:=Sheets(lap)
ActiveSheet.Name = Date & "_" & ujnev
Else
Sheets.Add After:=Sheets(lap)
ActiveSheet.Name = Date & "_1"
End If
Sheets(1).Select
Range("A1").Select
Selection.CurrentRegion.Select
lap = Worksheets.Count
Selection.Copy Sheets(lap).Range("A1")
Sheets(lap).Select
Selection.AutoFilter
Columns("A:A").ColumnWidth = 24
End Sub
Új hozzászólás Aktív témák
Hirdetés
- iPad topik
- Graphics: Telefonvásárlási kálváriám....avagy clickbait cím: Horror a hardveraprón
- Gyúrósok ide!
- Budapest és környéke adok-veszek-beszélgetek
- TCL LCD és LED TV-k
- Bestbuy játékok
- Audi, Cupra, Seat, Skoda, Volkswagen topik
- World of Tanks - MMO
- Gitáros topic
- Milyen asztali (teljes vagy fél-) gépet vegyek?
- További aktív témák...
- GYÖNYÖRŰ iPhone 13 256GB Midnight -1 ÉV GARANCIA - Kártyafüggetlen, MS4447, 100% Akkumulátor
- Apple iPhone 15 256GB Sárga Független Bontatlan / 27% áfás számla
- WD SN8000S 4TB M.2 2280 NVMe SSD Gen4 7300-6800MB/s
- Asus TUF A15 FX506 - 15.6" Full HD 144Hz - Ryzen 5-4600H - 8GB - 512GB - Win11 - GTX 1650 Ti - HUN
- HP ElitBook 840 G10 netbook / 12 hónap jótállás
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest


Fferi50
