- Yettel topik
- Honor 200 Pro - mobilportré
- Milyen okostelefont vegyek?
- Samsung Galaxy S24 Ultra - ha működik, ne változtass!
- Android alkalmazások - szoftver kibeszélő topik
- Mobil flották
- Samsung Galaxy Fit 3 - keveset, de jól
- iPhone topik
- Érkezik a Samsung Health előfizetés?
- Nem lett arányos a fogyókúra
-
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
Ha a beírt függvénnyel kész vannak a lapok, nem akarsz mást ellenőrizni, módosítani rajtuk, akkor a mostani makróba az End Sub fölé írd be egy új sorba annak a makrónak a nevét, amelyiket a mentésre kiválasztottad (LapMentes, vagy MentTorol).
Akkor elég a mostanit indítanod, minden feladatot elvégez. -
Delila_1
veterán
Van megoldás.
Sub Kulon_Lapra_2()
Dim sor As Long, lapnev As String, WS1 As Worksheet, usor As Long
Application.ScreenUpdating = False
Set WS1 = ActiveSheet
'egyedi rekordok az AA oszlopba
WS1.Range("B1:B" & Application.CountA(WS1.Columns(2))).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
sor = 2
Do While Cells(sor, "AA") <> ""
lapnev = Cells(sor, "AA")
WS1.Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:=lapnev 'szűrés
Sheets.Add After:=Sheets(Sheets.Count) 'új lap létrehozása
ActiveSheet.Name = lapnev
WS1.Range("A1").CurrentRegion.Copy Sheets(lapnev).Cells(1) 'másolás
'képlet az U:W-be
usor = Application.WorksheetFunction.CountA(Columns(22)) + 1
Range("U" & usor & ":W" & usor) = "=subtotal(9,U2:U" & usor - 1 & ")"
WS1.Activate
sor = sor + 1
Loop
WS1.Range("A1").CurrentRegion.AutoFilter Field:=2 'szűrő visszaállítása
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
Akkor gyorsítsunk – bár úgy tapasztaltam, hogy sok sor esetén nem túl gyors az Excelben a szűrés.
A makró a B oszlop adataiból speciális szűréssel kimásolja az egyedi adatokat az AA oszlopba, onnan veszi, hogy milyen adatokra kell szűrni a tartományt. Ha az AA oszlopban vannak adataid, minden helyen írd át az AA-t nagyobb oszlop nevére.Az adatokat tartalmazó lapon állva kell indítani a makrót.
Sub Kulon_Lapra_1()
Dim sor As Long, lapnev As String, WS1 As Worksheet
Application.ScreenUpdating = False
Set WS1 = ActiveSheet
'egyedi rekordok az AA oszlopba
WS1.Range("B1:B" & Application.CountA(WS1.Columns(2))).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
sor = 2
Do While Cells(sor, "AA") <> ""
lapnev = Cells(sor, "AA")
WS1.Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:=lapnev 'szűrés
Sheets.Add After:=Sheets(Sheets.Count) 'új lap létrehozása
ActiveSheet.Name = lapnev
WS1.Range("A1").CurrentRegion.Copy Sheets(lapnev).Cells(1) 'másolás
WS1.Activate
sor = sor + 1
Loop
WS1.Range("A1").CurrentRegion.AutoFilter Field:=2 'szűrő visszaállítása
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
3 makrót írtam. Az első sorra veszi a B oszlop celláit. Ha még nincs ennek megfelelő lap a füzetben, létrehozza, átmásolja a címsort és az aktuális sort. Az új lap neve az aktuális sor B oszlopában lévő adat lesz. Ha már van ilyen nevű lap, az első üres sorába másolja az aktuális sort. Nem kell az első lapon rendezettnek lennie a táblának.
A második sorra veszi a lapokat a másodiktól az utolsóig, Új füzetbe másolja az aktuális lapot, ezt elmenti a lapnév nevével az utvonal nevű változóban megadott mappába. Ezt a makró elején kell átírnod az
utvonal = "C:\Temp\"
sorban a saját mentési útvonaladra.Ha az eredeti füzetben nem akarod megtartani az újonnan létrehozott lapokat, akkor a második helyett a harmadik makrót futtasd. Ez nem másolja, hanem áthelyezi a lapokat 1-1 új füzetbe. Itt is át kell írnod az utvonal változó értékét.
A két másolós makró feltételezi, hogy kezdetkor 1 lap volt a füzetedben.
Sub Kulon_Lapra()
Dim sor As Long, lapnev As String, a, hova As Long, WS1 As Worksheet
Application.ScreenUpdating = False
Set WS1 = ActiveSheet
sor = 2
Do While Cells(sor, 1) <> ""
lapnev = Cells(sor, "B")
On Error Resume Next
Set a = Sheets(lapnev)
If Err.Number <> 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = lapnev
WS1.Rows(1).Copy Sheets(lapnev).Cells(1)
WS1.Activate
End If
On Error GoTo 0
hova = Application.WorksheetFunction.CountA(Sheets(lapnev).Columns(1)) + 1
Rows(sor).Copy Sheets(lapnev).Cells(hova, 1)
sor = sor + 1
Loop
Application.ScreenUpdating = True
End SubSub LapMentes()
Dim lap As Long, utvonal As String, lapnev As String
utvonal = "C:\Temp\"
Application.ScreenUpdating = False
For lap = 2 To Sheets.Count
lapnev = Sheets(lap).Name
Sheets(lapnev).Copy
ActiveWorkbook.SaveAs Filename:=utvonal & lapnev & ".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End SubSub MentTorol()
Dim lap As Long, utvonal As String, lapnev As String
utvonal = "C:\Temp\"
Application.ScreenUpdating = False
For lap = Sheets.Count To 2 Step -1
lapnev = Sheets(lap).Name
Sheets(lapnev).Move
ActiveWorkbook.SaveAs Filename:=utvonal & lapnev & ".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub -
azopi74
addikt
Igen azt. Bocsi, nem néztem meg, magyar excelben hogyan fordították az iterációt. Most megtettem.
Hát valóban közelítésnek
bocs, nem akartalak félrevezetni, úgy gondoltam simán hagyták iterációnak vagy iteratív kalkulációnak. De nem, muszáj volt leferdíteni.
Természetesen nem közelítésről van szó, és az iteráció sem közelítést jelent szó szerint sem, hanem ismétlődést (programozásban ciklus-nak is hívjuk). Csakhát úgy tűnik google translate-tel honosították az excelt
Ugyanis matematikában valóban majnem a közelítés az iteráció szinonimája, mivel az ismétlődést tartalmazó algoritmusokat a matematikában általában valóban közelítésre szoktuk használni, de IT-ban nem csak (és nem elsősorban). Innen jöhetett a félreferdítés. -
Fferi50
Topikgazda
Szia!
Az A1 cellát másolod és ugyanoda beilleszted értékként, de ez elég macerás minden adatbevitel után.
Ezért javaslom a következő makrót:Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 2 Then Exit Sub
If Target.Value <> "" Then
Application.EnableEvents = False
Target.Offset(0, -1).Value = Now()
Application.EnableEvents = True
End If
End SubEzt úgy viheted be, hogy a munkalapfülre jobb egérgombbal rákattintasz, kód megjelenítése, majd a megjelent kódlapon az üres területre bemásolod.
A makró azt csinálja, ha a B oszlop egy cellájába adatot írsz (vagy megváltoztatod az ott levő adatot), akkor beírja az A oszlopban mellette levő cellába a Most függvény értékét, ami természetesen nem fog a továbbiakban változni.
Üdv.
-
Delila_1
veterán
A laphoz kell rendelned a makrót. Mikor a B oszlopba beírsz valamit, az A oszlop azonos sorában fixen, nem képletként megjelenik az idő. Az oszlop formátumát tetszésed szerint adhatod meg, dátummal, vagy anélkül.
Ha törölsz a B-ben, az A azonos sorából is törlődik a beírt időpont. Ha 1-nél több cellába viszel be egyszerre adatot, akkor nem ír be semmit.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column = 2 Then
If Target = "" Then
Cells(Target.Row, 1) = ""
Exit Sub
Else
Cells(Target.Row, 1) = Now
End If
End If
End Sub
Új hozzászólás Aktív témák
Hirdetés
- Home server / házi szerver építése
- NVIDIA GeForce RTX 5080 / 5090 (GB203 / 202)
- PlayStation 5
- Audi, Cupra, Seat, Skoda, Volkswagen topik
- Yettel topik
- Honor 200 Pro - mobilportré
- EA Sports WRC '23
- Milyen okostelefont vegyek?
- Milyen széket vegyek?
- Samsung Galaxy S24 Ultra - ha működik, ne változtass!
- További aktív témák...
- ROBUX ÁRON ALUL - VÁSÁROLJ ROBLOX ROBUXOT MÉG MA, ELKÉPESZTŐ KEDVEZMÉNNYEL (Bármilyen platformra)
- Gyermek PC játékok
- 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.
- Eladó steam/ubisoft/EA/stb. kulcsok Bank/Revolut/Wise (EUR, USD, crypto OK)
- Nike Airmax 720 43-as sneaker eladó
- AKCIÓ! MSI B365M i5 8600 16GB DDR4 512GB SSD RX 5700XT 8GB CM MASTERBOX Q300L Zalman 600W
- AKCIÓ! Gigabyte H610M i5 13600K 16GB DDR4 512GB SSD RTX 3060Ti 8GB Zalman S2 TG Seasonic 650W
- Bomba ár! Lenovo ThinkPad X390: i5-G8 I 16GB I 256GB SSD I 13,3" FHD Touch I Cam I W11 I Gari!
- Bomba ár! Dell Latitude 7320 - i5-11GEN I 8GB I 256SSD I HDMI I 13,3" FHD I Cam I W11 I Garancia!
Állásajánlatok
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest
Cég: PC Trade Systems Kft.
Város: Szeged