Új hozzászólás Aktív témák

• #33305 Fferi50 Topikgazda Declare #33301

  Új Válasz 2016-11-23 15:19:27 #33305

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz Declare #33301 üzenetére

  Szia!

  Egy picit kellett módosítani rajta:
  Sub adogat()
Dim kezdrng As Range, vegrng As Range, ws1 As Worksheet, celrng As Range, elsocim As String, gewerkrng As Range, kezdocim As String ' a második ciklus kezdőcímének tárolására
Set ws1 = ActiveSheet
'megkeressük az elso 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 kezdo sort / Titel /
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(2, -1).Address & ":" & vegrng.Offset(-1, -1).Address & ")"
vegrng.Offset(0, -1).NumberFormat = "#,##0.00 $"
vegrng.Offset(0, -1).HorizontalAlignment = xlRight

End If
'következo 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 elsohöz, kilépünk
Loop
'megkeressük az elso S. Gewerk cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Bereich", 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 elso cellát
Do While Not vegrng Is Nothing
'megkeressük az elso S. Titelt a Gewerkben
Set kezdrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, After:=vegrng, searchdirection:=xlPrevious)
kezdocim = kezdrng.Address
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íto képletet
vegrng.Offset(0, -1).NumberFormat = "#,##0.00 $"
vegrng.Offset(0, -1).Font.Bold = True
vegrng.Offset(0, -1).HorizontalAlignment = xlRight
Exit Do
End If
Else
vegrng.Offset(0, -1).Formula = "=Sum(" & celrng.Offset(0, -1).Address & ")" ' ha már az elozo Gewerkhez visszaértünk, akkor beírjuk az összesíto képletet
vegrng.Offset(0, -1).NumberFormat = "#,##0.00 $"
vegrng.Offset(0, -1).Font.Bold = True
vegrng.Offset(0, -1).HorizontalAlignment = xlRight
Exit Do
End If
'megkeressük a következo S. Titel cellát:
Set kezdrng = ws1.Columns("G").Find(what:="S. Titel", LookIn:=xlValues, lookat:=xlWhole, After:=kezdrng, searchdirection:=xlPrevious)
If kezdrng.Address = kezdocim Then Exit Do 'ha nincs több S. Titel, akkor kilépünk EZ AZ EGYIK ÚJ SOR
Loop
Set gewerkrng = vegrng ' a Gewerk területet változtatjuk
'megkeressük a következo S. Gewerk cellát:
Set vegrng = ws1.Columns("G").Find(what:="S. Bereich", LookIn:=xlValues, lookat:=xlWhole, After:=vegrng, searchdirection:=xlNext)
'INNEN MÓDOSULT
If vegrng.Address = elsocim Then 'ha visszaértünk az elso találathoz
If Application.IsFormula(vegrng.Offset(0, -1)) Then 'és már van képletünk, akkor végeztünk
Exit Do
Else ' egyébként betesszük a képletet és utána végeztünk
vegrng.Offset(0, -1).Formula = "=Sum(" & celrng.Offset(0, -1).Address & ")" ' ha már az elozo Gewerkhez visszaértünk, akkor beírjuk az összesíto képletet
vegrng.Offset(0, -1).NumberFormat = "#,##0.00 $"
vegrng.Offset(0, -1).Font.Bold = True
vegrng.Offset(0, -1).HorizontalAlignment = xlRight
Exit Do
End If
End If
Loop

End Sub
  Remélem így már rendben lesz.

  Üdv.

Új hozzászólás Aktív témák