- sziku69: Fűzzük össze a szavakat :)
- sziku69: Szólánc.
- Luck Dragon: Asszociációs játék. :)
- gban: Ingyen kellene, de tegnapra
- eBay-es kütyük kis pénzért
- ubyegon2: Airfryer XL XXL forrólevegős sütő gyakorlati tanácsok, ötletek, receptek
- MasterDeeJay: Gigabyte GA-B350M-D2 - AM4 lap 2016-ból amikor még nem volt Ryzen!
- Magga: PLEX: multimédia az egész lakásban
- Elektromos rásegítésű kerékpárok
- D1Rect: Nagy "hülyétkapokazapróktól" topik
-
LOGOUT
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
-
Fferi50
Topikgazda
válasz
Declare #32697 üzenetére
Szia!
Az alábbi makrót okoskodtam össze, feltétel, hogy minden S. Titel előtt a G oszlopban legyen Titel:
Sub osszeado()
Dim kezdrng As Range, vegrng As Range, ws1 As Worksheet, celrng As Range, elsocim As String, gewerkrng As Range
Set ws1 = ActiveSheet
'megkeressük az első S. Titel cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext, after:=Range("G1"))
elsocim = vegrng.Address 'megjegyezzük a címét, mert itt kell leállítani
Do While Not vegrng Is Nothing
'megkeressük a kezdő sort
Set kezdrng = ws1.Columns("G").Find(what:="Titel", LookIn:=xlValues, lookat:=xlWhole, after:=vegrng, searchdirection:=xlPrevious)
If kezdrng.Row < vegrng.Row Then 'ha kisebb mint az S. Titel helye, akkor összeadjuk
vegrng.Offset(0, -1).Formula = "=Sum(" & kezdrng.Offset(1, -1).Address & ":" & vegrng.Offset(-1, -1).Address & ")"
End If
'következő S. Titel
Set vegrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, after:=vegrng, searchdirection:=xlNext)
If vegrng.Address = elsocim Then Exit Do 'ha visszaértünk az elsőhöz, kilépünk
Loop
'megkeressük az első S. Gewerk cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Gewerk", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext, after:=Range("G1"))
elsocim = vegrng.Address: Set gewerkrng = Range("G1") 'megjegyezzük a helyét és a lehetséges első cellát
Do While Not vegrng Is Nothing
'megkeressük az első S. Titelt a Gewerkben
Set kezdrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, after:=vegrng, searchdirection:=xlPrevious)
Set celrng = kezdrng
Do While Not kezdrng Is Nothing
If kezdrng.Row > gewerkrng.Row Then ' ha benne van a tartományban
If kezdrng.Row < vegrng.Row Then ' és oda tartozik, akkor bevesszük az összesítésbe
Set celrng = Union(kezdrng, celrng)
Else
vegrng.Offset(0, -1).Formula = "=Sum(" & celrng.Offset(0, -1).Address & ")" 'ha nincs benne, akkor beírjuk az összesítő képletet
Exit Do
End If
Else
vegrng.Offset(0, -1).Formula = "=Sum(" & celrng.Offset(0, -1).Address & ")" ' ha már az előző Gewerkhez visszaértünk, akkor beírjuk az összesítő képletet
Exit Do
End If
'megkeressük a következő S. Titel cellát:
Set kezdrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, after:=kezdrng, searchdirection:=xlPrevious)
Loop
Set gewerkrng = vegrng ' a Gewerk területet változtatjuk
'megkeressük a következő S. Gewerk cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Gewerk", LookIn:=xlValues, lookat:=xlWhole, after:=vegrng, searchdirection:=xlNext)
If vegrng.Address = elsocim Then Exit Do 'ha visszaértünk az első találathoz, akkor végeztünk
Loop
MsgBox "A képleteket beírtam!", vbInformation
End SubElőször összesíti az S. Titel cellákhoz az adatot, majd az S Gewerk cellákét csinálja meg.
Remélem, jól fog működni, ha gond lenne, írj lsz.
Üdv.
Új hozzászólás Aktív témák
Hirdetés
- Windows 10/11 Home/Pro , Office 2024 kulcsok
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.
- 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
- Keresem az alábbi PC játékokat! (Teljes lista a leírásban!)
- BESZÁMÍTÁS! LENOVO IdePad Gaming 3 Gamer notebook - R5 5600H 16GB DDR4 512GB SSD RTX 3050Ti 4GBWIN11
- Honor X6 64GB, Kártyafüggetlen, 1 Év Garanciával
- 154 - Lenovo LOQ (15IRX9) - Intel Core i5-13450HX, RTX 4060
- HIBÁTLAN iPhone XS Max 64GB Gold -1 ÉV GARANCIA - Kártyafüggetlen, MS2898, 100% Akkumulátor
- PlayStation Network (PSN) ajándékkártyák, feltöltőkártyák áron alul!
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest