AW: Werte addieren und Zeile loeschen
06.11.2018 10:15:18
Sait
Option Explicit
Sub Löschen()
Dim i As Long, j As Long
Dim lngS As Long ' die letzte belegte Spalte in Zeile 4
Dim lngZ As Long ' die letzte belegte Zeile in Spalte A
Dim dblS As Double
Dim rngA As Range
On Error GoTo Ende
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Tabelle1")
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row
lngS = .Cells(4, Columns.Count).End(xlToLeft).Column
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).Sort _
Key1:=.Cells(4, 1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Range(.Cells(5, lngS + 2), .Cells(lngZ, lngS + 2)).FormulaLocal = "=Wenn(A5A4;ZÄHLENWENN(A: _
A;A5);0)"
For i = 5 To lngZ
If .Cells(i, lngS + 2) > 1 Then
If .Cells(i, 1) = .Cells(i + 1, 1) Then
For j = 2 To lngS
dblS = Application.WorksheetFunction.Sum(.Range(.Cells(i, j), .Cells(i + .Cells(i, _
lngS + 2) - 1, j)))
If dblS > 0 Then
If Application.Count(.Range(.Cells(i, j), .Cells(i + .Cells(i, lngS + 2) - 1, j))) > _
1 Then
.Cells(i, lngS + 1) = 1
If rngA Is Nothing Then
Set rngA = .Cells(i, j)
Else
Set rngA = Union(rngA, .Cells(i, j))
End If
End If
.Cells(i, j) = dblS
End If
Next j
End If
End If
Next i
.Range(.Cells(5, 1), .Cells(lngZ, lngS)).Interior.ColorIndex = xlNone
If Not rngA Is Nothing Then
rngA.Interior.ColorIndex = 3
End If
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).RemoveDuplicates Columns:=1, Header:=xlYes
.Columns(lngS + 2).Clear
If Not rngA Is Nothing Then
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row
lngS = .Cells(4, Columns.Count).End(xlToLeft).Column
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).Sort _
Key1:=.Cells(4, lngS), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Set rngA = Nothing
End If
End With
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Ende:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err Then MsgBox "Fehler: " & Err.Number & vbLf & vbLf & Err.Description
End Sub