Selektive Datenübernahme

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Servus,


Private Sub Workbook_Open()
Dim n As String
Dim zeile As Integer, reihe As Integer
n = ActiveWorkbook.Name
Workbooks.Open Filename:= "C:\ ..." ' Hier Pfad von A
With Workbooks("A.xls").Sheets("DeinBlattname")
reihe = Range("F65536").End(xlUP).Offset(0, 0).Row
For zeile = 1 To reihe Step 1
If Cells(zeile, 6).Value = "XYZ" Then
Cells(zeile, 6).EntireRow.Copy Destination:= Workbooks(n).Sheets("ZielTabelle). _
Range("A65536").End(xlUp).Offset(1, 0)
End if
Next zeile
End with
End Sub

kopiert alles, was XYZ in Spalte F stehen hat in das neue Workbook unten dran, allerdings jedesmal alles.
Weiß nicht, ob dir damit geholfen ist, weil du ja unter Umständen Daten doppelt drin hast.
oder so:


Private Sub Workbook_Open()
Dim n As String
Dim zeile As Integer, reihe As Integer, reihe 2 As Integer, zeile1 As Integer
n = ActiveWorkbook.Name
Workbooks.Open Filename:= "C:\ ..." ' Hier Pfad von A
With Workbooks("A.xls").Sheets("DeinBlattname")
reihe = .Range("F65536").End(xlUP).Offset(0, 0).Row
For zeile = 1 To reihe Step 1
If .Cells(zeile, 6).Value = "XYZ" Then
.Cells(zeile, 6).EntireRow.Copy Destination:= Workbooks(n).Sheets("ZielTabelle) _
.Cells(zeile, 1)
End if
Next zeile
End with
With Workbooks(n).Sheets("ZielTabelle")
reihe2 = .Range("F65536").End(xlUP).Offset(0, 0).Row
For zeile1 = reihe To 1 Step -1
If .Cells(zeile1, 1).Value = "" Then
.Cells(zeile1, 1).EntireRow. Delete
End if
Next zeile1
End with
End Sub

schreibt die kopierten Daten in die jeweilige Zeile (Quellzeile = Zielzeile) und löscht dann, die evtl. Leerzeilen.
Ausprobieren, obs geht (Extramappe)
Gruß
Chaos

Servus,
ist das immer ein bestimmter Bereich, den du übertragen willst, also z.B.: A1:H1
dann kann man auch schreiben.
Workbooks("A.xls").Sheets("DeinBlattname").Range(Cells(zeile ,1), Cells(zeile, 8)).Copy Destination:= Workbooks(n).Sheets("Zieltabelle").Cells(zeile, 1)
oder wenn dir das lieber ist.
Workbooks("A.xls").Sheets("DeinBlattname").Range("A" & zeile & ":H" & zeile).Copy Destination:= Workbooks(n).Sheets("Zieltabelle").Cells(zeile, 1)
Das mit den Formaten, hab ich nicht richtig verstanden, willst du die aus A übernehmen oder die in b belassen?
aus A, dann eben nicht mit Destination arbeiten, sondern:
Workbooks("A.xls").Sheets("DeinBlattname").Range("A" & zeile & ":H" & zeile).Copy
With Workbooks(n).Sheets("Zieltabelle")
.Range("A" & zeile & ":H" & zeile).PasteSpecial Paste:=xlPasteValues
.Range("A" & zeile & ":H" & zeile).PasteSpecial Paste:=xlPasteFormats
End with
aus B
Workbooks("A.xls").Sheets("DeinBlattname").Range("A" & zeile & ":H" & zeile).Copy Destination:= Workbooks(n).Sheets("Zieltabelle").Cells(zeile, 1)
With Workbooks(n).Sheets("Zieltabelle")
.Range("A" & zeile & ":H" & zeile).NumberFormat = "m/d/yyyy"
End with
einzelne zellen geht auch ist aber ziemlich umständlich, je nachdem wieviele pro zeile.
gruß
Chaos

Sub aktuell() Dim zeile As Integer, reihe As Integer, z As Integer, zeile1 As Integer, reihe1 As Integer Dim n As String Application.ScreenUpdating = False n = ActiveWorkbook.Name z = ActiveWorkbook.Sheets(1).Range("A65536").End(xlUp).Offset(0, 0).Row With ActiveWorkbook.Sheets(1) If z

Beliebteste Forumthreads (12 Monate)

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread