Ausgewählte Zeile in verschiedene Spalte kopieren

Hallo,
ich suche schon lange nach einer Lösung, aber finden tue ich keine.
Ich möchte von der Haupttabelle in die zweite Tabelle ("Tabelle1") ausgewählte Zeilen kopieren, dies ist ja nicht sonderlich schwer.
Doch sobald ich jetzt die ausgewählten Zeilen neuen Spalten zu ordnen möchte weiß ich einfach nicht weiter :(
Die Haupttabelle hat über 15 Spalten (Header) und die Tabelle1 hat nur 6 Spalten, doch diese Spalten haben den selben Namen wie aus der Haupttabelle!
Ich habe mal das hier gefunden:
http://stackoverflow.com/questions/28474279/copy-data-from-one-workbook-to-another-using-column-header
Doch bei dieser Funktion wird das ganze Sheet kopiert. Doch ich will nur das die Zeile kopiert wird die ausgewählt ist. Die neue Zeile soll der Tabelle1 beigefügt werden (Also nach der letzten Zeile der Tabelle hinzugefügt werden). Es soll auch möglich sein mehrere Auswahlen (Zeilen) zu wählen und auf einmal zu kopieren.
Bitte Hilft mir.

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Styler,
nachfolgende ein entsprechendes Makro.
Gruß
Franz

Sub CopySelection()
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim rngRow As Range, rngQ As Range, rngZ As Range
Dim arrSpa() As Long, Spalte As Long
Dim rngHeaderQ As Range, rngHeaderZ As Range
Dim ZeileQ As Long, ZeileZ As Long, StatusCalc As Long
Set wksQ = ActiveWorkbook.Worksheets("Haupttabelle")  'ggf. anpassen
Set wksZ = ActiveWorkbook.Worksheets("Tabelle1")      'ggf. anpassen
'Spaltentitel in Haupttabelle - ggf. anpassen
Set rngHeaderQ = wksQ.Range("A1:O1")
'Spaltentitel in Tabelle1 - ggf. anpassen
Set rngHeaderZ = wksZ.Range("A1:F1")
StatusCalc = Application.Calculation
If ActiveSheet.Name  wksQ.Name Then
MsgBox "Beim Start des Makros muss Tabelle """ & wksQ.Name _
& """ das aktive Blatt sein!"
GoTo Beenden
End If
'Makrobremsen lösen
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With wksZ.UsedRange
'nächste freie Zeile in Zieltabelle
ZeileZ = .Row + .Rows.Count
End With
'Spaltenverweise ermitteln
With rngHeaderQ
ReDim arrSpa(.Column To .Column + .Columns.Count - 1, 1 To 2)
For Each rngQ In .Cells
arrSpa(rngQ.Column, 1) = rngQ.Column
'Spaltentitel in Haupttabelle in Titelzeile der Tabelle1 suchen
Set rngZ = rngHeaderZ.Find(What:=rngQ.Value, LookIn:=xlValues, lookat:=xlWhole)
If rngZ Is Nothing Then
arrSpa(rngQ.Column, 2) = 0
Else
arrSpa(rngQ.Column, 2) = rngZ.Column
End If
Next
End With
'selektierte Zeilen abarbeiten
For Each rngRow In Selection.EntireRow.Rows
ZeileQ = rngRow.Row
For Spalte = LBound(arrSpa, 1) To UBound(arrSpa, 1)
If arrSpa(Spalte, 2) > 0 Then
wksQ.Cells(ZeileQ, arrSpa(Spalte, 1)).Copy _
wksZ.Cells(ZeileZ, arrSpa(Spalte, 2))
End If
Next
ZeileZ = ZeileZ + 1
Next
Beenden:
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = StatusCalc
End With
Set rngHeaderQ = Nothing: Set rngHeaderZ = Nothing
Set rngQ = Nothing: Set rngZ = Nothing
Set wksQ = Nothing: Set wksZ = Nothing
End Sub

Beliebteste Forumthreads (12 Monate)

Ausgewählte Zeile in verschiedene Spalte kopieren

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ausgewählte Zeile in verschiedene Spalte kopieren

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread