Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1388to1392
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Daten Suchen und Kopieren

Daten Suchen und Kopieren
23.10.2014 10:07:19
B
Hallo,
ich habe versucht ein Makro zuschreiben, welches aus der geöffneten Datei eine Projektnamen Zeile "A1" ausliest, anschließend eine weitere Exceldatei öffnet, in dieser in Spalte "G" nach dem Projektnamen sucht und anschließend die betreffende Zeile von der geöffneten Seite auswählt und in die zu anfangs erstellte Datei kopiert (am besten nur Werte). Dabei ist es möglich, dass der Projektname mehrmals in der Quelldatei vorkommt, in dem Fall sollen alle Treffer kopiert werden.
Leider funktioniert das Makro nicht, kann mir jemand helfen?
Vielen Dank im Vorraus.

Sub Kopieren()
Dim Zeile As Long
Dim ZeileMax As Long
Dim i As Long
Dim ZielWb As Workbook
Set ZielWb = ThisWorkbook
Projekt = Range("A1").Value
Workbooks.Open ("R:\Allgemein\Rein\Reinklein2014.xlsx")
With Tabelle1
ZeileMax = .UsedRange.Rows.Count
n = 1
For Zeile = 2 To ZeileMax
If .Cells(Zeile, 7).Value = Projekt Then
.Rows(Zeile).Copy Destination:=ZielWb(Tabelle1).Rows(n)
n = n + 1
ZielWb.Activate
Workbooks("R:\Allgemein\Rein\Reinklein2014.xlsx").Close savechanges:=False
End If
Next Zeile
End With
End Sub

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Daten Suchen und Kopieren
23.10.2014 12:12:19
Tino
Hallo,
kannst mal so testen!
Im Code die entsprechenden Daten anpassen.
Sub Kopieren()
Dim Zeile As Long
Dim ZeileMax As Long
Dim n As Long
Dim Projekt
Dim Quell As Workbook, QuellSheet As Worksheet, rngQuelle As Range
On Error GoTo ErrorHandler:
Application.ScreenUpdating = False
Application.EnableEvents = False
'Projekt suche, Tabelle und Zelle anpassen
Projekt = Tabelle2.Range("A1").Value
'einfügen ab Zeile
n = 1
'Pfad Datei anpassen
Set Quell = Workbooks.Open("R:\Allgemein\Rein\Reinklein2014.xlsx")
'Tabelle Quelle anpassen
Set QuellSheet = Quell.Sheets("Tabelle1")
With Tabelle1 'Zieltabelle anpassen
ZeileMax = QuellSheet.UsedRange.Rows.Count
For Zeile = 2 To ZeileMax
If QuellSheet.Cells(Zeile, 7).Value = Projekt Then
If Not rngQuelle Is Nothing Then
Set rngQuelle = Union(rngQuelle, QuellSheet.Rows(Zeile))
Else
Set rngQuelle = QuellSheet.Rows(Zeile)
End If
End If
Next Zeile
If Not rngQuelle Is Nothing Then
''evtl. alte Daten löschen ************
'.Rows(n).Resize(.Rows.Count - n + 1).Clear
rngQuelle.Copy
.Rows(n).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
End With
ErrorHandler:
If Not Quell Is Nothing Then Quell.Close savechanges:=False
Application.EnableEvents = True
Application.ScreenUpdating = True
If Err.Number  0 Then
MsgBox Err.Description, _
vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub
Gruß Tino

Anzeige
AW: Daten Suchen und Kopieren
23.10.2014 13:42:58
B
Super, das klappt vielen Dank für deine Hilfe :)
Ich habe nur eine Verständnisfrage was genau macht:
If Not rngQuelle Is Nothing Then
Set rngQuelle = Union(rngQuelle, QuellSheet.Rows(Zeile))
Else
Set rngQuelle = QuellSheet.Rows(Zeile)

AW: Daten Suchen und Kopieren
23.10.2014 14:51:53
Tino
Hallo,
diese Zeilen fassen die gefundenen Datenbereiche zusammen.
Um eine Union zu bilden, muss die Variable "rngQuelle" mindestens aus einen Zelleberich bestehen.
Daher wenn diese noch keinen Bereich hat, wird zuerst mal einer zugewiesen.
Set rngQuelle = QuellSheet.Rows(Zeile)

Danach kann man mit Union den Bereits vorhandenen und den neuen vereinigen.
Set rngQuelle = Union(rngQuelle, QuellSheet.Rows(Zeile))
Aus der Hilfe "Union-Methode"
Gibt die Vereinigung von mindestens zwei Bereichen zurück.
Gruß Tino

Anzeige
AW: Daten Suchen und Kopieren
23.10.2014 15:53:17
B
Super, vielen Dank für die Erklärung :)

With Tabelle1 --> With sheets("Tabelle1") o.T.
23.10.2014 12:13:42
MCO
Gruß, MCO

309 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige