update
30.10.2022 18:43:35
ralf_b
und was ist damit?
Option Explicit
Sub sbStart()
Dim lstrow As ListRow
Range("F2:F" & Cells(Rows.Count, 6).End(xlUp).Row).ClearContents
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlManual
End With
With ActiveSheet.ListObjects("Tabelle1")
'wenn Name der Tabelle im Original anders, dann hier anpassen
For Each lstrow In .ListRows
With lstrow.Range
If .Cells(1).Value vbNullString And _
.Cells(2).Value vbNullString And _
.Cells(4).Value vbNullString Then
If Not IsNumeric(.Cells(3).Value) Or _
.Cells(3).Value = vbNullString Then 'numerische Werte überspringen
.Cells(3).Value = sbPLZ(.Cells, "PLZ")
End If
Else
.Cells(3).Value = vbNullString
'wenn Daten von Strasse, PLZ und Ort fehlen dann Nummer leer lassen
End If
End With
Next
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With
End Sub
Function sbPLZ(rng As Range, ByVal blatt As String)
Dim larr, lRow&, lCol&
Dim var1$, var2$, var3$, var4$
With Worksheets(blatt)
larr = .UsedRange
var1 = rng.Cells(1).Value
var2 = rng.Cells(2).Value
'var3 = rng.Cells(3).Value
var4 = rng.Cells(4).Value
'schleife rückwärts über Spalten
For lCol = UBound(larr, 2) To LBound(larr, 2) Step -1
If larr(1, lCol) Like "STRASSE*" Then
''schleife über Zeilen
For lRow = LBound(larr) To UBound(larr)
If larr(lRow, lCol - 1) = var2 And _
LCase(larr(lRow, lCol)) = LCase(var1) Then 'Prüfung Strasse
sbPLZ = CDbl(larr(lRow, lCol - 2))
Exit Function 'Austieg wenn gefunden
End If
Next
Else 'Wenn Strasse kein Treffer, suche nach Ort-Spalte
If larr(1, lCol) Like "ORT*" Then
For lRow = LBound(larr) To UBound(larr)
If CStr(larr(lRow, lCol - 1)) = var2 And _
LCase(larr(lRow, lCol)) = LCase(var4) Then 'Prüfung "Ort"
sbPLZ = CDbl(larr(lRow, lCol - 2))
Exit Function 'Austieg wenn gefunden
End If
Next
End If
End If
Next
sbPLZ = "?" 'Rückgabewert wenn nicht gefunden
End With
End Function