AW: Ausgewählte Zeile in verschiedene Spalte kopieren
16.09.2015 07:02:06
fcs
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