Quick&Dirty lt. Muster
Option Explicit
Sub Test()
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)
'über alle Zeilen
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
.Value = .Value - .Offset(, -1).Value
Else
.Value = ""
End If
End With
Next rngRow
End With
End With
End Sub
Private Function FiltIt(Sh As Worksheet, Nme As Variant, Wrt As String) As Double
Dim rngF As Range, rngV As Range
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
|