AW: SVerweis ? in VBA
09.07.2009 08:54:08
Tino
Hallo,
Teste mal diesen Code, habe diesen nicht ausgiebig getestet.
Die verbundenen Zellen machen es zwar etwas schwieriger, aber nicht unlösbar.
Die Daten werden aktualisiert nach Eingabe einer Fachnummer in der Spalte A oder bei Änderung der Fachnummer.
kommt als Code in Fach 25
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rZelle As Range, rSuchBereich As Range, FindZelle As Range
Dim BearbeitungsBereich As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
If Not Intersect(Target, Range("A3", Cells(26, 1))) Is Nothing Or Target.Address = "$B$1" Then
If Target.Address = "$B$1" Then
Set BearbeitungsBereich = Range("A3", Cells(26, 1))
Else
BearbeitungsBereich = Target
End If
With Sheets("Stammdaten")
Set rSuchBereich = .Range("H:K")
For Each rZelle In BearbeitungsBereich
If (rZelle.Row Mod 2) = 1 Then
If rZelle <> "" Then
.UsedRange.AutoFilter 7, Range("B1")
Set FindZelle = rSuchBereich.SpecialCells(xlCellTypeVisible).Find(rZelle, , xlValues, 1, 2, 1, False, False)
If Not FindZelle Is Nothing Then
Cells(rZelle.Row, 2) = .Cells(FindZelle.Row, 1)
Cells(rZelle.Row, 3) = .Cells(FindZelle.Row, 2)
Cells(rZelle.Row + 1, 3) = .Cells(FindZelle.Row, 3)
Cells(rZelle.Row, 4) = .Cells(FindZelle.Row, 5)
Else
Range(rZelle, Cells(rZelle.Row + 1, 4)).Value = ""
End If
Else
Range(rZelle, Cells(rZelle.Row + 1, 4)).Value = ""
End If
End If
Next rZelle
.UsedRange.AutoFilter
End With
End If
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Gruß Tino