Sub Uebertragen_Frucht_1()
Uebertragen_Frucht "Tabelle1", "Tabelle2"
End Sub
Function Uebertragen_Frucht(Ziel As String, Quelle As String)
Dim colDummy As Collection
Dim colZeilen As New Collection
Dim i As Long
Dim k As Long
Dim colQuelle As Long
Dim colZiel As Long
Dim strSearch As String
Dim varDummy As Variant
Dim wsZiel As Worksheet
Dim wsQuelle As Worksheet
Dim dtmBeginn As Date
On Error Resume Next
dtmBeginn = Now
Set wsZiel = Worksheets(Ziel)
Set wsQuelle = Worksheets(Quelle)
With wsQuelle
For i = 5 To 50
strSearch = CStr(.Cells(i, 1))
If strSearch <> "" Then
Set colDummy = New Collection
colZeilen.Add colDummy, "X-" & strSearch
colZeilen("X-" & strSearch).Add i, "Quellzeile"
End If
Next
strSearch = wsQuelle.Range("D4").Text
Set varDummy = wsZiel.Rows(10).Find(what:=strSearch, LookIn:=xlValues, lookat:=xlWhole)
If varDummy Is Nothing Then
MsgBox "Frucht """ & strSearch & """ nicht in Zeile 4 der Zieltabelle gefunden!"
GoTo Beenden
Else
colZiel = varDummy.Column
End If
End With
With wsZiel
For i = 5 To 50
strSearch = CStr(.Cells(i, 1))
If strSearch <> "" Then
colZeilen("X-" & strSearch).Add i, "Zielzeile"
End If
Next
strSearch = wsZiel.Range("D4").Text
Set varDummy = wsQuelle.Rows(4).Find(what:=strSearch, LookIn:=xlValues, lookat:=xlWhole)
If varDummy Is Nothing Then
MsgBox "Frucht """ & strSearch & """ nicht in Zeile 4 der Quelltabelle gefunden!"
GoTo Beenden
Else
colQuelle = varDummy.Column
End If
End With
With wsZiel
Application.ScreenUpdating = False
For Each varDummy In colZeilen
i = varDummy("Zielzeile")
k = varDummy("Quellzeile")
.Cells(i, colZiel).Value = wsQuelle.Cells(k, colQuelle).Value
Next
End With
Beenden:
Application.ScreenUpdating = True
End Function