AW: Viele Spalten untereinander
09.01.2015 18:18:28
fcs
Hallo Karl Heinz,
Makro-Lösung, die ein neues Blatt anlegt und die Spalten des Quellblatts einzeln kopiert und im Zielblatt in Spalte A untereinander einfügt.
Gruß
Franz
Sub AlleSpalten_untereinander()
Dim wks As Worksheet, wksZ As Worksheet
Dim Spalte As Long, Spalte_L As Long, rngCopy As Range, Zeile_Z As Long
Dim bolNurWerteFormate As Boolean
Dim StatusCalc As Long
Set wks = ActiveSheet
bolNurWerteFormate = True 'ggf. ändern in False
'neues Blatt anlegen für Daten in einer Spalte
ActiveWorkbook.Worksheets.Add after:=wks
Set wksZ = ActiveSheet
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
With wks
Spalte_L = .UsedRange.Column + .UsedRange.Columns.Count - 1 ' 729
Zeile_Z = 1
For Spalte = 1 To Spalte_L
Application.StatusBar = "Kopiere Spalte: " & Spalte
Set rngCopy = .Range(.Cells(1, Spalte), .Cells(.Rows.Count, Spalte).End(xlUp))
If bolNurWerteFormate = True Then
rngCopy.Copy
With wksZ.Cells(Zeile_Z, 1)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With
Else
rngCopy.Copy Destination:=wksZ.Cells(Zeile_Z, 1)
End If
'nächste Einfügezeile
Zeile_Z = Zeile_Z + rngCopy.Rows.Count
Next Spalte
End With
With Application
.CutCopyMode = False
.StatusBar = False
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub