Option Explicit
Sub SpalteTausch(nRechts As Boolean)
Dim lngSpalteVon As Integer, lngSpalteBis As Integer
Dim lngR As Long
Dim rng As Range, rngR As Range
Dim arr As Variant, sngBreit As Single
lngSpalteVon = 1
lngSpalteBis = 20
lngR = IIf(nRechts, 1, -1)
Set rng = ActiveSheet.UsedRange.Columns(ActiveCell.Column)
If lngSpalteVon
Option Explicit
Sub SpalteTauschAb2(nRechts As Boolean)
Dim lngSpalteVon As Integer, lngSpalteBis As Integer
Dim lngR As Long, lngC As Long, lngA As Long, lngB As Long
Dim rng As Range, rngR As Range, arr As Variant
lngSpalteVon = 1
lngSpalteBis = 20
lngR = IIf(nRechts, 1, -1)
If lngSpalteVon lngB Then _
Cells(lngB + 1, lngC).Resize(lngA - lngB).ClearContents ' Rest löschen
rng.Offset(, lngR) = arr ' gemerkte Werte in andere Spalte
If lngA
Option Explicit
Sub SpalteTauschAb2(nRechts As Boolean)
Dim lngU As Long, lngSpalteVon As Long, lngSpalteBis As Long
Dim lngR As Long, lngC As Long, lngA As Long, lngB As Long
Dim rng As Range, rngR As Range, arr As Variant
lngU = 1 ' Anzahl Überschriftzeilen
lngSpalteVon = 1 ' linkeste zulässige Spalte
lngSpalteBis = 20 ' rechteste zulässige Spalte
lngR = IIf(nRechts, 1, -1)
If lngSpalteVon lngU Then
Set rng = Cells(lngU + 1, lngC).Resize(lngA - lngU)
arr = rng ' Werte der aktuellen Spalte merken
End If
lngB = Cells(Rows.Count, lngC + lngR).End(xlUp).Row
If lngB > lngU Then
Set rngR = Cells(lngU + 1, lngC + lngR).Resize(lngB - lngU)
rngR.Offset(, -lngR) = rngR.Value ' aktuelle Spalte überschreiben
End If
If lngA > lngB Then _
Cells(lngB + 1, lngC).Resize(lngA - lngB).ClearContents ' Rest löschen
If Not rng Is Nothing Then _
rng.Offset(, lngR) = arr ' gemerkte Werte in andere Spalte
If lngA Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen