Hirdetés
-
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
Egy halom idézőjelet tettél bele feleslegesen, és a $-t kihagytad.
Jelöld ki az A2:F4 területet. A formázás képlete: =$E2="nem"
Add meg a formátumot, és kész. Új szabály, ugyanez a képlet, csak a "nem" helyére "igen" jön, és a háttér zöld.A további sorokra a formátumfestő ecsettel másolhatod a formátumot, vagy a feltételes formázás | Szabályok kezelése ablakában egyszerűen átírod az érvényességet a teljes területedre.
-
Delila_1
veterán
Érvényesítésben add meg a két választható elemet.
A feltételes formázásnál erre a cellára kell hivatkoznod. Ha pl. a B oszlopban van az érvényesítés, az adatok meg A2-től Q1000-ig, akkor kijelölöd a teljes területet. A feltételes formázáshoz 2 képletet vigyél be.
=$B2="igen" és =$B2="nem". A két képlethez külön add meg a két háttérszínt. Fontos a $ jel az érvényesítést tartalmazó oszlop betűjele előtt. -
-
Delila_1
veterán
A működéshez tedd meg az alábbi lépéseket:
Office gomb, Az Excel beállításai, Bővítmények. Balra lent a Kezelések közül Excel bővítmények, Ugrás, a kapott felsorolás első két bővítménye elé tegyél pipát, OK.Az első (gyűjtő) lapodhoz rendelve marad a
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then karbantart
End Submakró, ami figyeli az A1 cella változását.A modulba kerül a másik makró,
Sub karbantart()
Dim sorGy%, lap%, sorLap%, usorLap%
sorGy% = 2
Sheets(1).Select
Rows("2:10000").ClearContents
For lap% = 2 To Worksheets.Count
Sheets(lap%).Select
usorLap% = Sheets(lap%).Range("A50000").End(xlUp).Row
For sorLap% = 2 To usorLap%
If Cells(sorLap%, 5) + Cells(sorLap%, 6) <= Sheets(1).Cells(1) Then
Range(Cells(sorLap%, 1), Cells(sorLap%, 6)).Copy Sheets(1).Cells(sorGy%, 1)
sorGy% = sorGy% + 1
End If
Next
Next
Sheets(1).Select
End Subami a kigyűjtést végzi. A számítás alapja, hogy az egyes lapokon az utolsó karbantartás idejéhez hozzáadja a következő karbantartáshoz szükséges napokat (E+F), és ha ez a nap kisebb, vagy egyenlő, mint a gyűjtő lap A1 cellájába írt dátum, akkor bemásolja az egyes alkatrészek adatait a lapokról az A:F oszlopokból.
-
perfag
aktív tag
Dolgom volt du., közben látom Delila már adott rá megoldást, de ha már kész, ide teszem.
Sub copy_data()
Dim rng As Range
Dim tcell As Range
Dim w, i, j, k As Integer
'előkészítés
j = 1 'célcella számláló
k = 2 'dátum oszlop távolsága jobbról
'a gyűjtőlapon C4-be kezd adatot áthozni
Set tcell = Worksheets(1).Range("C4")
'de előbb lefelé 100 cellának törli a tartalmát
Range(tcell(1), tcell(100)).ClearContents
'munkalapok
For w = 2 To 6
'az adatok D3:D8-ban
Set rng = Worksheets(w).Range("D3:D8")
'vizsgáódás, másolás
For i = 1 To 5
If Not rng(i) = Empty Then
'a mai naphoz képest mi régebbi, mint 3 hónap,
'ám én inkább 90 napot használnék:
'If DateDiff("d", rng(i, k), Now) >= 90 Then
If DateDiff("m", rng(i, k), Now) >= 3 Then
tcell(j) = rng(i)
j = j + 1
End If
End If
Next
Next -
Delila_1
veterán
Az két makró ezt csinálja:
Ha az első lap A1 cellájába beírod a dátumot, automatikusan indul a kigyűjtés erre a lapra, A2-től kezdődően. A beírás indítja az első makrót, ami nekilódítja a másikat.Az utóbbi végigszalad a másodiktól az utolsó lapig. Minden lapon végignézi az A oszlopban tárolt dátumokat soronként (amik feltehetően az utolsó karbantartás dátumai).
Ahol az első lap A1-es dátumánál 90 nappal, vagy annál régebbi dátumot talál, a sor első 15 oszlopát (A:O oszlopok) átmásolja az első lapra egymás alá.Ahhoz, hogy automatikusan induljon a kért dátum beírásakor, 2 makró szükséges.
Az elsőt a gyűjtő (első) laphoz rendeld, a másodikat modulba.Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then karbantart
End Sub
.
Sub karbantart()
Dim sorGy%, lap%, sorLap%, usorLap%
sorGy% = 2
Rows("2:10000").ClearContents
For lap% = 2 To Worksheets.Count
Sheets(lap%).Select
usorLap% = Sheets(lap%).Range("A65000").End(xlUp).Row
For sorLap% = 2 To usorLap%
If Sheets(1).Cells(1) - Sheets(lap%).Cells(sorLap%, 1) >= 90 Then
Range(Cells(sorLap%, 1), Cells(sorLap%, 15)).Copy Sheets(1).Cells(sorGy%, 1)
sorGy% = sorGy% + 1
End If
Next
Next
Sheets(1).Select
End SubHa több oszlopod van, mint 15, a
Range(Cells(sorLap%, 1), Cells(sorLap%, 15)).Copy Sheets(1).Cells(sorGy%, 1)
sorban írd át a 15-öt. -
perfag
aktív tag
Mondjuk nem tudom mekkora alkatrész bázissal dolgozol, de meg lehet kerülni a makrót. Először is a dátumok közötti különbséget kell kezelni, innen el lehet indulni:
Dátumok és időpontok használata az Excel programban
"az első lapra azoknak az alkatrészeknek a nevét kiírná amik karbantartásra szorulnak." ehhez egy gyűjtögető makró kellene, de minek. Szerintem meg lehetne oldani, hogy az első lapon egy oszlopban megjelennek az alkatrésznevek, mellettük meg az eltelt idő. Vagy egyszerű sorba rendezéssel kigyűjtheted a szükséges alkatrészeket, vagy feltételes formázással mondjuk piros lesz azoknak az alkatrészeknek a neve ahol matatni kell.
). Kettőnél viszont már tudja, hogy csak egy bizonyos területen akarod végrehajtani a műveletet.
Új hozzászólás Aktív témák
Hirdetés
Fferi50- 4K vs 8K – Megéri-e a 8K TV 2026-ban?
- Túllépne a DRAM limitjein a Neo Semiconductor-féle 3D X-DRAM
- Autós topik
- Graphics: Telefonvásárlási kálváriám....avagy clickbait cím: Horror a hardveraprón
- Linux haladóknak
- Ha Darwinra hallgat az AI, nehéz lesz megállítani
- Arc Raiders
- Motoros topic
- Milyen NAS-t vegyek?
- Apple MacBook
- További aktív témák...
- Játékkulcsok ! : PC Steam, EA App, Ubisoft, Windows és egyéb játékok
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Kaspersky, BitDefender, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- Game Pass Ultimate előfizetések 3 - 36 hónapig azonnali kézbesítéssel! 13 hónap ultimate - 50.000 ft
- 121 - Lenovo Legion Pro 5 (16ARX8) - AMD Ryzen 7 7745HX, RTX 4070 (ELKELT)
- BESZÁMÍTÁS! Asrock Z790 i9 13900K 64GB DDR5 1TB SSD RTX4080 16GB Aerocool P500B Digi ARGB ADATA 850W
- BESZÁMÍTÁS! Gigabyte B450M R5 3600X 32GB DDR4 512GB SSD RTX 3060 12GB NZXT Source 340 Bitfenix 550W
- Dell Precision 5560,15.6",FHD+, i7-11850H,16GB DDR4,1TB SSD,Nvidia T1200 4GB VGA,WIN11
- Xiaomi Redmi Note 8 Pro 64GB, Kártyafüggetlen, 1 Év Garanciával
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest