Moin,
selbstplaudernd könnte man(n) auch zum Rechnen die Finger (div. Variable) zu Hilfe nehmen.
Nur, wozu brauch ich Krücken, wenn ich schon im Auto fahre?
LG
Sub Tast()
Dim Tab1 As Excel.Worksheet, Tab2 As Excel.Worksheet
Dim RngU As Range, rngRow As Range
Set Tab1 = Sheets("Tabelle1")
Set Tab2 = Sheets("Tabelle2")
'
With Tab1
With .Columns("B:Q")
'Umfang der Suche
Set RngU = Range(.Cells(1), .Cells(.Cells.Count).End(xlUp))
'habe Überschrift
Set RngU = RngU.Offset(1).Resize(RngU.Rows.Count - 1)
'ein wenig Schmuck
RngU.Interior.Color = xlNone
'über alle Zeilen
' 1. Name und total Wert aus Tabelle 1 entnehmen
For Each rngRow In RngU.Rows
'schreibe Ergebnis der Substraktion rechts von (in Ergebnis)
With rngRow.Cells(rngRow.Cells.Count).Offset(, 1)
.Value = FiltIt(Tab2, rngRow.Cells(1).Value, ">" & _
Replace(CStr(rngRow.Cells(rngRow.Cells.Count).Value), ",", "."))
'nur wenn
If .Value > 0 Then
' 3. vom total Wert aus Tabelle 2 den total Wert aus Tabelle 1 abziehen
.Value = .Value - .Offset(, -1).Value
' 4. alten total Wert in Tabelle 2 mit neuem Ergebnis überschreiben
.Offset(, -1).Value = .Value
'ein wenig Schmuck
.Offset(, -1).Interior.Color = 14277081
End If
.Value = ""
End With
Next rngRow
End With
End With
'Vielen Dank
End Sub
Private Function FiltIt(Sh As Worksheet, Nme As Variant, Wrt As String) As Double
Dim rngF As Range, rngV As Range
' 2. In Tabelle 2 nach Namen filtern
With Sh
If .AutoFilterMode Then .AutoFilterMode = False
With .Columns("B:Q")
Set rngF = Range(.Cells(1), .Cells(.Cells.Count).End(xlUp))
With rngF
On Error Resume Next
.AutoFilter Field:=1, Criteria1:=Nme
.AutoFilter Field:=16, Criteria1:=Wrt, Operator:=xlAnd
Set rngV = rngF.Offset(1).Resize(rngF.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
'nimmt den erste Wert wo größer
FiltIt = rngV.Columns(16).Cells(1).Value
On Error GoTo 0
End With
End With
End With
End Function
|