Option Explicit
Public Sub Beispiel()
Dim blnEE As Boolean
Dim blnSU As Boolean
blnEE = Application.EnableEvents
blnSU = Application.ScreenUpdating
Application.EnableEvents = False
Application.ScreenUpdating = False
On Error GoTo ErrHandler
Dim wksQuelle As Excel.Worksheet
Dim wksZiel As Excel.Worksheet
Dim rngQuelle As Excel.Range
Dim rngZiel As Excel.Range
Dim rngZeile As Excel.Range
Set wksQuelle = Worksheets("Tabelle1")
Set wksZiel = Worksheets("Tabelle2")
Set rngQuelle = wksQuelle.Range("A1").CurrentRegion
If rngQuelle.Columns.Count < 3 Then
Call MsgBox("Tabelle muss mindestens 3 Spalten umfassen." & vbNewLine & _
"Vorgang wird abgebrochen.", _
vbExclamation)
GoTo SafeExit
End If
Set rngZiel = wksZiel.Range("B2")
rngZiel.Resize(ColumnSize:=3).Value = Array("Teil", "LO", "MELDE")
Set rngZiel = rngZiel.Offset(RowOffset:=1)
With rngQuelle.Resize(RowSize:=rngQuelle.Rows.Count - 1).Offset(RowOffset:=1)
For Each rngZeile In .Rows
rngZiel.Resize(RowSize:=rngZeile.Cells.Count - 2).Value = rngZeile.Cells(1).Value
Call rngZeile.Resize(ColumnSize:=rngZeile.Cells.Count - 2).Offset(ColumnOffset:=1).Copy
Call rngZiel.Offset(ColumnOffset:=1).PasteSpecial(xlPasteValues, Transpose:=True)
rngZiel.Offset(ColumnOffset:=2).Value = rngZeile.Cells(rngZeile.Cells.Count).Value
Set rngZiel = rngZiel.Offset(RowOffset:=rngZeile.Cells.Count - 2)
Next
End With
If Not ActiveSheet Is Nothing Then
If Not rngZiel.Worksheet Is ActiveSheet Then
Set wksQuelle = ActiveSheet
rngZiel.Worksheet.Activate
rngZiel.Select
Call wksQuelle.Activate
Else
rngZiel.Select
End If
End If
GoTo SafeExit
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.Number)
SafeExit:
Application.CutCopyMode = False
Application.EnableEvents = blnEE
Application.ScreenUpdating = blnSU
End Sub