- Android alkalmazások - szoftver kibeszélő topik
- Profi EKG-s óra lett a Watch Fitből
- Honor 400 Pro - gép a képben
- Samsung Galaxy S21 és S21+ - húszra akartak lapot húzni
- Honor Magic7 Pro - kifinomult, költséges képalkotás
- Samsung Galaxy A54 - türelemjáték
- Milyen okostelefont vegyek?
- Telekom mobilszolgáltatások
- Apple iPhone 16 Pro - rutinvizsga
- India felől közelít egy 7550 mAh-s Redmi
-
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- Nyaralás topik
- Vicces képek
- Xbox Series X|S
- One otthoni szolgáltatások (TV, internet, telefon)
- Delta Force (2024)
- Sütés, főzés és konyhai praktikák
- lezso6: Nem látszik a kurzor Chrome alatt a beviteli mezőkben?
- Call of Duty: Black Ops 6
- Autós topik látogatók beszélgetős, offolós topikja
- Vezetékes FEJhallgatók
- További aktív témák...
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Sea of Thieves Premium Edition és Egyéb Játékkulcsok.
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Adobe Előfizetések - Adobe Creative Cloud All Apps - 12 Hónap - NYÁRI AKCIÓ!
- AKCIÓ! ASUS PRIME Z390-P i5 8600K 16GB DDR4 512GB SSD RX 6600 8GB GDDR6 DEEPCOOL Matrexx55 630W
- BESZÁMÍTÁS! MSI B450 TomaHawk R5 3600 16GB DDR4 512GB SSD RX5500 XT 8GB Rampage SHIVA TT 530W
- Tablet felvásárlás!! Apple iPad, iPad Mini, iPad Air, iPad Pro
- Bomba ár! Lenovo X1 Yoga 2nd - i7-7G I 8GB I 256SSD I 14" WQHD I HDMI I W11 I CAM I Garancia!
- BESZÁMÍTÁS! ASUS B450 R7 2700X 16GB DDR4 512GB SSD RTX 2060 Super 8GB Zalman i3 FSP 600W
Állásajánlatok
Cég: PC Trade Systems Kft.
Város: Szeged
Cég: PC Trade Systems Kft.
Város: Szeged