Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender Navigationstipps
Inhaltsverzeichnis

Finden und Kopieren

Finden und Kopieren
03.10.2019 14:44:13
Mark
Hallo Ihr VBA Bestien,
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

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Finden und Kopieren
03.10.2019 19:10:42
ChrisL
Hi Mark
Set wksSrc = Workbooks("xy.xlsm").Sheets("Suchen&Kopieren")
Ohne explizite Angabe referenzierst du immer auf die aktive Mappe (ActiveWorkbook).
cu
Chris
AW: Finden und Kopieren
03.10.2019 19:13:26
ChrisL
dito hier...
Set wksDst = ThisWorkbook.Sheets(ZielName)

AW: Finden und Kopieren
04.10.2019 13:00:45
ChrisL
Hi
Ich hatte erst interpretiert, dass mehrere Mappen im Spiel sind, aber vermutlich läuft der Prozess innerhalb der gleichen Mappe.
Die Problemursache könnte die fehlende Referenzierung zum Tabellenblatt in folgender Zeile sein:
wksSrc.Range("A" & ZeSrc & ":C" & ZeSrc).Copy
Jedenfalls habe ich dir den Code mal etwas aufgeräumt.
Sub t()
Const strZiel As String = "Ziel"
Dim wksSrc As Worksheet, wksDst As Worksheet, wksTemp As Worksheet
Dim strSuch As String, intCounter As Long
Application.ScreenUpdating = False
' Tabellen festlegen
With ThisWorkbook
Set wksSrc = .Worksheets("Suchen&Kopieren")
For Each wksTemp In .Worksheets
If wksTemp.Name = strZiel Then
Set wksDst = wksTemp
Exit For
End If
Next wksTemp
If wksDst Is Nothing Then
.Sheets.Add After:=.Worksheets(Worksheets.Count)
Set wksDst = ActiveSheet
wksDst.Name = strZiel
End If
End With
With wksSrc
' Plausi
If Trim(.Range("F4")) = "" Then
MsgBox "Die Zelle F4 ist leer, darum kann nicht gesucht werden", _
vbExclamation, " Fehler "
Exit Sub
End If
strSuch = .Range("F4")
If WorksheetFunction.CountIf(.Columns(2), strSuch) = 0 Then
MsgBox "Leider wurde  '" & strSuch & "'  nicht gefunden!", vbInformation, "Fehleingabe?"
Exit Sub
End If
' Kopieren
For intCounter = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(intCounter, 2) = strSuch Then _
.Range(.Cells(intCounter, 1), .Cells(intCounter, 3)).Copy _
wksDst.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next intCounter
End With
End Sub

cu
Chris
Anzeige
AW: Finden und Kopieren
04.10.2019 18:46:32
ChrisL
ein letztes Selbstgespräch...
Hier fehlt noch ein Punkt
.Sheets.Add After:=.Worksheets(.Worksheets.Count)

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige