Marko verschieben modifizieren; Hallo Sepp
Lemmi
Hallo zusammen!
ich habe von Sepp ein Makro geschrieben bekommen, welches die Zeilen und Spalten mit Inhalt verschiebt.
Das Makro funktioniert soweit auch ganz gut!
Nun habe ich immer wieder Arbeitsblätter in dem ich Gliederungen in den Spalten und Zeilen eingebunden habe. Setzte ich die Gliederung in Funktion so werden Zeilen oder Spalteninhalte ausgeblendet.
Genau hier liegt das Problem sind Gliederungen eingebunden und Zeilen oder Spalten ausgeblendet so werden diese Inhalte überschrieben/ ignoriert!
Wie könnte das Makro angepasst werden um die Inhalte der ausgeblendeten Spalten und Zeilen zu berücksichtigen!
Mein Idealwunsch wäre es , wenn die Gliederung nicht zurück gesetzt werden müsste und die Ansicht so verbleibt wie sie ist!
**********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_Activate()
Application.OnKey "%{UP}", "'moveSelection ""up""'"
Application.OnKey "%{DOWN}", "'moveSelection ""down""'"
Application.OnKey "%{LEFT}", "'moveSelection ""left""'"
Application.OnKey "%{RIGHT}", "'moveSelection ""right""'"
End Sub
Private Sub Workbook_Deactivate()
Application.OnKey "%{UP}"
Application.OnKey "%{DOWN}"
Application.OnKey "%{LEFT}"
Application.OnKey "%{RIGHT}"
End Sub
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub moveSelection(Direction As String)
Dim rng As Range, objTarget As Worksheet, objSh As Worksheet
Dim rngMove As Range
Dim lngFirstRow As Long, lngLastRow As Long, lngFirstCol As Long, lngLastCol As Long
Dim lngMove As Long, lngOld As Long, lngNew As Long
Dim lngStartRow As Long, lngStartCol As Long
Dim intMove As Integer
On Error GoTo ErrExit
GMS
lngStartRow = 6 'erste Zeile beim Spaltenverschieben - Anpassen!
lngStartCol = 4 'erste Spalte beim Zeilenverschieben - Anpassen!
Set rng = Selection
Set objTarget = rng.Parent
If LCase(Direction) = "up" Or LCase(Direction) = "down" Then
lngFirstRow = rng.Cells(1, 1).Row
lngLastRow = lngFirstRow + rng.Rows.Count - 1
ElseIf LCase(Direction) = "left" Or LCase(Direction) = "right" Then
lngFirstCol = rng.Cells(1, 1).Column
lngLastCol = lngFirstCol + rng.Columns.Count - 1
End If
With objTarget
If LCase(Direction) = "up" Then
If lngFirstRow = 1 Then GoTo ErrExit
lngMove = lngFirstRow - 1
lngOld = lngFirstRow - 1
lngNew = lngLastRow
intMove = -1
ElseIf LCase(Direction) = "down" Then
If lngLastRow = Rows.Count Then GoTo ErrExit
lngMove = lngFirstRow + 1
lngOld = lngLastRow + 1
lngNew = lngFirstRow
intMove = 1
ElseIf LCase(Direction) = "left" Then
If lngFirstCol = 1 Then GoTo ErrExit
lngMove = lngFirstCol - 1
lngOld = lngFirstCol - 1
lngNew = lngLastCol
intMove = -1
ElseIf LCase(Direction) = "right" Then
If lngLastCol = Columns.Count Then GoTo ErrExit
lngMove = lngFirstCol + 1
lngOld = lngLastCol + 1
lngNew = lngFirstCol
intMove = 1
End If
Set objSh = Worksheets.Add
If LCase(Direction) = "up" Or LCase(Direction) = "down" Then
.Range(.Cells(lngOld, lngStartCol), .Cells(lngOld, Columns.Count)).Copy objSh.Cells(1, lngStartCol)
Set rngMove = .Range(.Cells(lngFirstRow, lngStartCol), .Cells(lngLastRow, Columns.Count))
rngMove.Copy .Cells(lngMove, lngStartCol)
objSh.Range(objSh.Cells(1, lngStartCol), objSh.Cells(1, Columns.Count)).Copy .Cells(lngNew, lngStartCol)
.Activate
rng.Offset(intMove, 0).Select
ElseIf LCase(Direction) = "left" Or LCase(Direction) = "right" Then
.Range(.Cells(lngStartRow, lngOld), .Cells(Rows.Count, lngOld)).Copy objSh.Cells(lngStartRow, 1)
Set rngMove = .Range(.Cells(lngStartRow, lngFirstCol), .Cells(Rows.Count, lngLastCol))
rngMove.Copy .Cells(lngStartRow, lngMove)
objSh.Range(objSh.Cells(lngStartRow, 1), objSh.Cells(Rows.Count, 1)).Copy .Cells(lngStartRow, lngNew)
.Activate
rng.Offset(0, intMove).Select
End If
objSh.Delete
End With
ErrExit:
GMS True
Set objSh = Nothing
Set rng = Nothing
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Gruß
Egbert