Finden und Kopieren
03.10.2019 14:44:13
Mark
Ich hab schon einige Probleme gelöst aber komme mit einem Stück nicht weiter. Ich möchte von einer Tabelle (welche ich mit VBA aus dem Netzwerk ziehe) einige Daten suchen und in einer weiteren Tabelle kopieren.
Ich bin schon ziemlich weit aber brauche noch ein wenig Hilfe.
- Ich möchte das Suchen von der Ziel Tabelle nicht von der Suchen&Kopieren Tabelle aus starten
Vielleicht hat jemand eine Idee wie ich den Code ändern muß:
Sub FindAndCopy2c()
Dim rngSuch As Range, wksDst As Worksheet, wksSrc As Worksheet
Dim strSuch As String, rngFound As Range
Dim strFirst As String, FoundAdr As String
Dim ZeSrc As Integer, ZeDst As Integer, lRow As Long
Dim i As Integer, ZielOK As Boolean, ZielName As String
ZielName = "Ziel"
With ThisWorkbook
For i = 1 To ThisWorkbook.Sheets.Count
If .Sheets(i).Name = ZielName Then
ZielOK = True
Exit For
End If
Next i
If Not ZielOK Then
.Sheets.Add After:=.Worksheets(Worksheets.Count)
ActiveSheet.Name = ZielName
End If
End With
Set wksSrc = Sheets("Suchen&Kopieren")
With wksSrc
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rngSuch = .Range("B1:B" & lRow)
End With
Set wksDst = Sheets(ZielName)
With wksSrc
If Trim(wksSrc.Range("F4")) = "" Then
MsgBox "Die Zelle F4 ist leer, darum kann nicht gesucht werden", vbExclamation, " _
Fehler"
Exit Sub
End If
strSuch = .Range("F4")
.Range("F4").ClearContents
End With
With rngSuch
Set rngFound = .Find(what:=strSuch, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
FoundAdr = rngFound.Address
ZeSrc = rngFound.Row
ZeDst = wksDst.Cells(Rows.Count, 4).End(xlUp).Row + 1
Range("A" & ZeSrc & ":C" & ZeSrc).Copy wksDst.Cells(ZeDst, 1)
Set rngFound = .FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address strFirst
Else
MsgBox "Leider wurde '" & strSuch & "' nicht gefunden!", vbInformation, "Fehleingabe? _
_
_
_
End If
End With
End Sub