Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1096to1100
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Spalten verschieben; Hallo Sepp

Spalten verschieben; Hallo Sepp
Lemmi
Hallo Sepp,
könntest Du Dein nachfolgendes Marko Zeilen verschieben auf Spalten verschieben "umbauen/ ummünzen" ?
Auch Hier sollen alle Farben und Formeln unverändert bleiben!
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_Activate()
Application.OnKey "%{UP}", "moveUP"
Application.OnKey "%{DOWN}", "moveDOWN"
End Sub

Private Sub Workbook_Deactivate()
Application.OnKey "%{UP}"
Application.OnKey "%{DOWN}"
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub moveSelection(Optional Direction As String = "up")
Dim rng As Range, objTarget As Worksheet, objSh As Worksheet
Dim rngMove As Range
Dim lngFirst As Long, lngLast As Long, lngMove As Long, lngOld As Long, lngNew As Long
Dim intMove As Integer
On Error GoTo ErrExit
GMS
Set rng = Selection
Set objTarget = rng.Parent
lngFirst = rng.Cells(1, 1).Row
lngLast = lngFirst + rng.Rows.Count - 1
With objTarget
If LCase(Direction) = "up" Then
If lngFirst = 1 Then GoTo ErrExit
lngMove = lngFirst - 1
lngOld = lngFirst - 1
lngNew = lngLast
intMove = -1
Else
If lngLast = Rows.Count Then GoTo ErrExit
lngMove = lngFirst + 1
lngOld = lngLast + 1
lngNew = lngFirst
intMove = 1
End If
Set objSh = Worksheets.Add
.Range(.Cells(lngOld, 3), .Cells(lngOld, Columns.Count)).Copy objSh.Cells(1, 3)
Set rngMove = .Range(.Cells(lngFirst, 3), .Cells(lngLast, Columns.Count))
rngMove.Copy .Cells(lngMove, 3)
objSh.Range(objSh.Cells(1, 3), objSh.Cells(1, Columns.Count)).Copy .Cells(lngNew, 3)
objSh.Delete
rng.Offset(intMove, 0).Select
End With
ErrExit:
GMS True
Set objSh = Nothing
Set rng = Nothing
End Sub Sub moveUP()
moveSelection
End Sub Sub moveDOWN()
moveSelection "down"
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ß
Lemmi

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
All In One
16.08.2009 19:46:43
Josef
Hallo Lemmi,
das Makro reagiert nun auch auf rechts/links!
Probier's mal.
' **********************************************************************
' 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 = 2 'erste Zeile beim Spaltenverschieben - Anpassen!
  lngStartCol = 3 '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ß Sepp

Anzeige
AW: All In One
16.08.2009 21:27:31
Lemmi
Hallo Sepp,
einfach super!
Vielen vielen Dank!
Gruß
Lemmi

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige