Daten kopieren nach Überschrift

Sub copy_datat() Dim WkSh_Q As Worksheet Dim WkSh_Z As Worksheet Dim rZelle As Range, rZiel As Range Dim aUeberschr As Variant Dim iIndx As Integer aUeberschr = Array("Radlader", "Notiz", "Schaufel") Application.ScreenUpdating = False Set WkSh_Q = Workbooks("Mappe1.xlsx").Worksheets("Tabelle1") ' das Quell-Tabellenblatt Set WkSh_Z = Workbooks("Mappe2.xlsm").Worksheets("Tabelle1") ' das Ziel-Tabellenblatt For iIndx = 0 To UBound(aUeberschr) Set rZelle = WkSh_Q.Rows(4).Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:=xlValues) If Not rZelle Is Nothing Then Set rZiel = WkSh_Z.Rows(11).Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:=xlValues) If Not rZiel Is Nothing Then rZelle.EntireColumn.Copy Destination:=rZiel End If End If Next iIndx Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub copy_datat() Dim WkSh_Q As Worksheet Dim WkSh_Z As Worksheet Dim rZelle As Range, rZiel As Range Dim Ueberschr As Variant Application.ScreenUpdating = False Set WkSh_Q = Workbooks("Mappe1.xlsx").Worksheets("Tabelle1") ' das Quell-Tabellenblatt Set WkSh_Z = Workbooks("Mappe2.xlsm").Worksheets("Tabelle1") ' das Ziel-Tabellenblatt With WkSh_Q For Each Ueberschr In Array("Radlader", "Notiz", "Schaufel") Set rZelle = .Rows(4).Find(Ueberschr, LookAt:=xlWhole, LookIn:=xlValues) If Not rZelle Is Nothing Then .Cells(.Rows.Count, rZelle.Column).End(xlUp).Row Set rZiel = WkSh_Z.Rows(11).Find(Ueberschr, LookAt:=xlWhole, LookIn:=xlValues) If Not rZiel Is Nothing Then .Range(rZelle.Offset(1, 0), .Cells(.Rows.Count, rZelle.Column).End(xlUp)).Copy Destination:=rZiel.Offset(1, 0) End If End If Next End With Set WkSh_Q = Nothing Set WkSh_Z = Nothing Set rZelle = Nothing Set rZiel = Nothing Application.ScreenUpdating = True End Sub

Hallo Peter,
(Mist, Nepumuk war schon wieder schneller ;-)
Es ist ein Bisschen unglücklich, inmitten der Kopiererei zu prüfen, ob Quelle und Ziel vorhanden sind. Ich bevorzüge eine Prüfung vorab.
Wenn diese alle gefunden worden sind, kann man durchrauschen.
Die Suche + Ergebnis-Speichern ist mir noch zu viel Wiederholung, aber für ein ersten Wurf, wird es gehen.


Sub copy_datat()
Dim Überschriften()
Dim Spalten()
Dim R As Range
Dim Elt, i
Const Q = 0
Const cWb_Q = "Mappe1.xlsx"
Const cWsh_Q = "Tabelle1"
Const cÜbZ_Q = 4
Const Z = 1
Const cWb_Z = "Mappe2.xlsm"
Const cWsh_Z = "Tabelle1"
Const cÜbZ_Z = 11
Überschriften = Array("Radlader", "Notiz", "Schaufel")
ReDim Spalten(UBound(Überschriften), 1)
'Prüfung der Vollständigkeit
For Each Elt In Überschriften
Set R = Workbooks(cWb_Q).Worksheets(cWsh_Q).Rows(cÜbZ_Q).Find(Elt, LookAt:=xlWhole, LookIn:=xlValues)
If R Is Nothing Then
MsgBox "Spalte """ & Elt & """ in Quell-Tabelle [" & cWb_Q & "]" & cWsh_Q & " nicht gefunden."
Exit Sub
Else
Set Spalten(i, Q) = R.Offset(1, 0)
End If
Set R = Workbooks(cWb_Z).Worksheets(cWsh_Z).Rows(cÜbZ_Z).Find(Elt, LookAt:=xlWhole, LookIn:=xlValues)
If R Is Nothing Then
MsgBox "Spalte """ & Elt & """ in Ziel-Tabelle [" & cWb_Z & "]" & cWsh_Z & " nicht gefunden."
Exit Sub
Else
Set Spalten(i, Z) = R.Offset(1, 0)
End If
i = i + 1
Next
'Machen (wir wissen jetzt, dass alles vorhanden ist)
Application.ScreenUpdating = False
For i = LBound(Spalten, 1) To UBound(Spalten, 1)
Range(Spalten(i, Q), Spalten(i, Q).Offset(65000).End(xlUp)).Copy Destination:=Spalten(i, Z)
Next
Application.ScreenUpdating = True
End Sub

VG
Yal

Sub copy_datat() Dim Überschriften() Dim Spalten(1) As Variant '0:Quell-Zelle, 1:Ziel-Zelle Dim i 'Information sammeln und prüfen Überschriften = Array("Radlader", "Notiz", "Schaufel") Spalten(0) = Überschrift_finden("Mappe1.xlsx", "Tabelle1", 4, Überschriften) If UBound(Spalten(0)) UBound(Überschriften) Then Exit Sub Spalten(1) = Überschrift_finden("Mappe2.xlsm", "Tabelle1", 11, Überschriften) If UBound(Spalten(1)) UBound(Überschriften) Then Exit Sub 'Machen (wir wissen jetzt, dass alles vorhanden ist) Application.ScreenUpdating = False For i = 0 To UBound(Spalten(0)) Range(Spalten(0)(i), Spalten(0)(i).Offset(65000).End(xlUp)).Copy Destination:=Spalten(1)(i) Next Application.ScreenUpdating = True End Sub Private Function Überschrift_finden(WbName As String, WsName As String, ÜbZeile As Integer, Übersch()) Dim i Dim R As Range Dim Erg() ReDim Erg(UBound(Übersch)) For i = 0 To UBound(Übersch) Set R = Workbooks(WbName).Worksheets(WsName).Rows(ÜbZeile).Find(Übersch(i), LookAt:=xlWhole, LookIn:=xlValues) If R Is Nothing Then MsgBox "Spalte """ & Übersch(i) & """ in Quell-Tabelle [" & WbName & "]" & WsName & " nicht gefunden." Überschrift_finden = Array() 'Minus1-Init Exit Function Else Set Erg(i) = R.Offset(1, 0) End If Next Überschrift_finden = Erg End Function

Sub copy_datat() Dim WkSh_Q As Worksheet Dim WkSh_Z As Worksheet Dim rZelle As Range Dim rZiel As Range Dim aUeberschr As Variant Dim iIndx As Integer aUeberschr = Array("Radlader", "Notiz", "Schaufel") Application.ScreenUpdating = False Set WkSh_Q = Workbooks("Mappe1.xlsx").Worksheets("Tabelle1") ' das Quell-Tabellenblatt Set WkSh_Z = Workbooks("Mappe2.xlsm").Worksheets("Tabelle1") ' das Ziel-Tabellenblatt For iIndx = 0 To UBound(aUeberschr) Set rZelle = WkSh_Q.Rows(4).Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:=xlValues) If Not rZelle Is Nothing Then Set rZiel = WkSh_Z.Rows(11).Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:=xlValues) If Not rZiel Is Nothing Then rang(rZelle.Offset(1, 0), rZelle.Offset(99999).End(xlUp)).Copy Destination:=rZiel.Offset(1, 0) End If End If Next iIndx Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread