' (Tabelle 1, Tabelle 2), welche von der Struktur gleich aufgebaut sind
' in Tabelle 2 die fehlenden Namenskürzel auf Grundlage von Tabelle 1
' d.h. Kürzel in die leere Zelle Spalte A links vom Treffer in Spalte B
Option Explicit
'Voreinstellungen, ggf. ändern
Const cTAB1 As String = "Tabelle1" 'Name der Quelle
Const cTAB2 As String = "Tabelle2" 'Name der Zieltabelle
'
Sub DoIt()
Dim rngQ As Range, c As Range 'Quellbereich
Dim strAddi As String 'Bereichsangabe
Dim arrVergleich() As Variant 'Sammlung der Vergleichswerte
Dim x As Long 'Zähler
'
Application.ScreenUpdating = False
On Error GoTo fail
'in Tabelle 1 die benutzen Spalten A u. B
With Sheets(cTAB1)
Set c = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
Set rngQ = c.Offset(, -1)
Set rngQ = rngQ.Resize(rngQ.Rows.Count, 2)
'Adressbereich
strAddi = rngQ.Address(0, 0)
End With
'in eine temporäre Tabelle zum ausdünnen
ThisWorkbook.Sheets.Add
rngQ.Copy ActiveSheet.Cells(1, 1)
ActiveSheet.Range(strAddi).RemoveDuplicates Columns:=2, Header:=xlNo
'als Datenfeld merken
Set c = ActiveSheet.Cells(1, 1).CurrentRegion
arrVergleich = c.Value
'temp. wegwerfen
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
'in Tabelle 2 die Spalten B u. A mit dem Datenfeld durchsuchen
With Sheets(cTAB2)
'Bereich in Spalte B festlegen
Set rngQ = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
With rngQ
'Datenfeld abarbeiten
For x = LBound(arrVergleich, 1) To UBound(arrVergleich, 1)
'finde Spalre B - Wert
Set c = .Find(arrVergleich(x, 2), LookIn:=xlValues)
If Not c Is Nothing Then
strAddi = c.Address
Do
'wenn Treffer und links von leer
If c.Offset(, -1).Value = "" Then _
c.Offset(, -1).Value = arrVergleich(x, 1)
'nächste Suche
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> strAddi
End If
Next x
End With
End With
fail:
If Err.Number <> 0 Then Call MsgBox(Err.Description, vbOKOnly, "Fehler " & CStr(Err.Number))
Application.ScreenUpdating = False
End Sub
|