Das Archiv des Excel-Forums

Finden und Kopieren

nach unten


Betrifft: Finden und Kopieren
von: Mark

Geschrieben am: 03.10.2019 14:44:13

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

Betrifft: AW: Finden und Kopieren
von: ChrisL
Geschrieben am: 03.10.2019 19:10:42
Hi Mark

Set wksSrc = Workbooks("xy.xlsm").Sheets("Suchen&Kopieren")
Ohne explizite Angabe referenzierst du immer auf die aktive Mappe (ActiveWorkbook).
cu
Chris

Betrifft: AW: Finden und Kopieren
von: ChrisL

Geschrieben am: 03.10.2019 19:13:26
dito hier...
Set wksDst = ThisWorkbook.Sheets(ZielName)


Betrifft: AW: Finden und Kopieren
von: ChrisL
Geschrieben am: 04.10.2019 13:00:45
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

Betrifft: AW: Finden und Kopieren
von: ChrisL

Geschrieben am: 04.10.2019 18:46:32
ein letztes Selbstgespräch...
Hier fehlt noch ein Punkt
.Sheets.Add After:=.Worksheets(.Worksheets.Count)

Excel-Beispiele zum Thema "Finden und Kopieren"

Doppelte Einträge finden und löschen download Schaltflächen-Id-Nummer finden und Schaltfläche einfügen download
Datensätze wechselseitig bei Nichtauffinden markieren download Alle Zellen mit Formeln finden download
Blätter in andere Arbeitsmappen kopieren download Module von Mappe zu Mappe kopieren download
Arbeitsblatt 40 mal kopieren download Schriftgröße beim Kopieren verdoppeln download
Beim Kopieren auch die Zeilenhöhe und Spaltenbreite übernehmen download Tabellencode nach Kopieren des Blattes löschen download
Arbeitsmappe blitzschnell kopieren download VBE-Namen der Blattmodule beim Kopieren festlegen download
Blattinhalt von einer zur anderen Arbeitsmappe kopieren download Formel bis zur letzten Zeile der Nebenspalte kopieren download
Datei kopieren, wenn noch nicht vorhanden download Zeilenweise von Blatt zu Blatt kopieren download
Erste Druckseite in eine neue Arbeitsmappe kopieren download Durch DoppelKlick Spalte in zweites Arbeitsblatt kopieren download
Teilergebnisse einer Serie von Tabellen in anderes Blatt kopieren download Bei Eintrag in Spalte A aktuelle Zeile kopieren download
Filtern und Kopieren download Zeile mit aktiver Zelle in anderes Blatt kopieren download
Zeilen in Abhängigkeit des Wertes in Spalte A kopieren download Einen von einer Schlüsselziffer abhängigen Bereich kopieren download
Vorgegebene Anzahl von Einträgen in 2. Blatt kopieren download Über InputBox festzulegenden Bereich kopieren download
Passwortgeschützte Mappe öffnen, Daten kopieren, schliessen download Tabellenblatt kopieren und dreistellig fortlaufend numerieren download
Jede zweite Zelle kopieren download Werte aus UserForm-ComboBox suchen und Fundstelle kopieren download
Gruppe von Optionsfeldern kopieren und Makro zuweisen download Nicht zusammenhängenden Bereich in nächste Zeile kopieren download
Wert aus UserForm-TextBox suchen und Fundstelle kopieren download Nur sichtbare Zellen in anderes Arbeitsblatt kopieren download
Zeile in Abhängigkeit zur Eingabe in Blätter kopieren download Werte prüfen und kopieren download
Bei Eintrag von X Zeile in andere Tabelle kopieren download Daten kopieren wenn kein Datum oder Datum > Heute download
Blattinhalte dreier Blätter in neues Blatt kopieren download Kopieren und Umbenennen eines Blattes download
Nur Zeilen mit bestimmtem Inhalt kopieren download Artikelnummern nach Kriterien suchen und Datensätze kopieren download
Bild in zweites Blatt an gleiche Position kopieren download Alle Zeilen ohne Wert in vorgegebener Spalte kopieren download
Bei Eintrag Zeile in 2. Blatt kopieren und Tabellen sortieren download Bildergruppe in anderes Blatt kopieren download
Bei Eingabe Formel in der Nebenspalte nach unten kopieren download Auswahl in andere Arbeitsmappe kopieren, speichern, schließen download
Begriff suchen und Fundzeilen in anderes Blatt kopieren download Aktive Zeile kopieren und löschen download
Datensätze, die öfter als 3 mal vorkommen, kopieren download Den jeweils darüberliegenden Wert in Leerzellen kopieren download
Alle Zeilen mit einem Suchbegriff in nächstes Blatt kopieren download Dateien listen und Blätter in neue Arbeitsmappe kopieren download