Zeilen und Inhalte mittels Button verschieben

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Lemmi,
kopiere die Codeteile in die entsprechenden Module, Datei speichern, schliessen und wieder öffnen.
Mit "Alt+Pfeil auf" bzw. "Alt+Pfeil ab", wird der Code ausgeführt.

' **********************************************************************
' 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
  Dim varMove As Variant, varOld As Variant
  Dim lngFirst As Long, lngLast As Long, lngOld As Long

  Set rng = Selection
  lngFirst = rng.Cells(1, 1).Row
  lngLast = lngFirst + rng.Rows.Count - 1

  If lngFirst = 1 And LCase(Direction) = "up" Then Exit Sub
  If lngLast = Rows.Count And LCase(Direction) = "down" Then Exit Sub

  If LCase(Direction) = "up" Then
    varOld = Range(Cells(lngFirst - 1, 3), Cells(lngFirst - 1, Columns.Count))
    varMove = Range(Cells(lngFirst, 3), Cells(lngLast, Columns.Count))
    Range(Cells(lngFirst, 3), Cells(lngLast, Columns.Count)).Offset(-1, 0) = varMove
    Range(Cells(lngLast, 3), Cells(lngLast, Columns.Count)) = varOld
    rng.Offset(-1, 0).Select
  ElseIf LCase(Direction) = "down" Then
    varOld = Range(Cells(lngLast + 1, 3), Cells(lngLast + 1, Columns.Count))
    varMove = Range(Cells(lngFirst, 3), Cells(lngLast, Columns.Count))
    Range(Cells(lngFirst, 3), Cells(lngLast, Columns.Count)).Offset(1, 0) = varMove
    Range(Cells(lngFirst, 3), Cells(lngFirst, Columns.Count)) = varOld
    rng.Offset(1, 0).Select
  End If

  Set rng = Nothing
End Sub

Sub moveUP()
  moveSelection
End Sub

Sub moveDOWN()
  moveSelection "down"
End Sub

Gruß Sepp

Hallo Lemmi,
erstens hattest du geschrieben
".... so sollen die Zeileninhalte um 1 Zeile nach oben verschoben werden!"
und zweitesns geht's dann nicht so einfach, aber bitte.

' **********************************************************************
' 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ß Sepp

Beliebteste Forumthreads (12 Monate)

Zeilen und Inhalte mittels Button verschieben

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

144 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilen und Inhalte mittels Button verschieben

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

144 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread