VBA code for Cut and pasting multiple selected rows

[rjheibel]

I currently have the code below written to allow a custom button on the right click menu. This was written to allow a user to cut and paste a row to a designated spot within a protected sheet. My question is, how do I get this code to allow the user to highlight multiple rows so they can cut and past a group of rows at the same time???

Public Sub cutProtectedRow()


    Application.EnableCancelKey = xlDisabled
 Dim ws As Worksheet
 On Error Resume Next
 Set ws = ActiveWorkbook.Sheets("LookAhead Schedule")
 On Error GoTo 0
 If ws Is Nothing Then
     MsgBox "Function Only Works in LookAhead Sheet!!!"
 Else
     If ws.Name = ActiveWorkbook.ActiveSheet.Name Then
        ActiveSheet.Unprotect "password"
        Rows(ActiveCell.row).Select
        Selection.Cut
'userbox to request location of the isert of cut rows
        Dim row
        row = InputBox("enter Row Number to insert row below")
        If Not row = vbNullString Then
            ActiveSheet.Range("A" & row + 1).EntireRow.Insert
        End If
'reprotect sheet
        ActiveSheet.Protect _
            Password:="Password", _
            DrawingObjects:=True, _
            Contents:=True, _
            Scenarios:=True, _
            AllowFiltering:=True
     Else
         MsgBox "Function Only Works in LookAhead Sheet!!!"
     End If
 End If
    Application.EnableCancelKey = xlInterrupt
End Sub

 

[John_w]

Try this macro. The user can highlight (select) multiple contiguous and non-contiguous rows via the Application.InputBox prompt.

Public Sub Move_Multiple_Rows()

    Dim ws As Worksheet
    Dim selectedRows As Range
    Dim row As String, rowArea As Range
    
    Application.EnableCancelKey = xlDisabled
    
    On Error Resume Next
    Set ws = ActiveWorkbook.Sheets("LookAhead Schedule")
    On Error GoTo 0
    
    If ws Is Nothing Then
        MsgBox "Function Only Works in LookAhead Sheet!!!"
    Else
        If ws.Name = ActiveWorkbook.ActiveSheet.Name Then
            On Error Resume Next
            Set selectedRows = Application.InputBox("Select row(s) to move, or click Cancel to exit", Type:=8)
            On Error GoTo 0
            If Not selectedRows Is Nothing Then
                row = InputBox("Enter row number to insert row(s) below")
                If row <> vbNullString Then
                    ActiveSheet.Unprotect "password"
                    For Each rowArea In selectedRows.Areas
                        rowArea.Cut
                        Rows(row + 1).EntireRow.Select
                        Selection.Insert Shift:=xlDown
                    Next
                    'reprotect sheet
                    ActiveSheet.Protect Password:="Password", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
                End If
            End If
        
        Else
            MsgBox "Function Only Works in LookAhead Sheet!!!"
        End If
    End If
    
    Application.EnableCancelKey = xlInterrupt

End Sub

 

[rjheibel]

John_W,

Thanks for the reply and solution! This code does allow the pasting of multiple rows.

2 more questions:

1)Would there be a way for the code to not have a text box to identify the rows to be cut, but instead recognize the already highlighted rows prior to the Right Click menu button being selected?

2) Would there be a way to only allow the cut and paste of rows if the row does not have a value in column C? And to return a text box stating it cant be moved if a value in column C exist?

Thanks!

 

[rjheibel]

Just to close out post, I figured out how to select the rows to move without the text box and also added an error check to ensure row c is empty. Might not be the prettiest code, but it works!

Public Sub cutProtectedRow()


    Dim ws As Worksheet
    Dim row As String, rowArea As Range
    Dim selRows As Range, CBlanks As Range, IntersectedCells As Range
    
    Application.EnableCancelKey = xlDisabled
    
    On Error Resume Next
    Set ws = ActiveWorkbook.Sheets("LookAhead Schedule")
    Set selRows = Selection.EntireRow
    Set CBlanks = Columns("C").SpecialCells(xlBlanks)
    Set IntersectedCells = Intersect(selRows, CBlanks)
      
    
    On Error GoTo 0
    
    If ws Is Nothing Then
        MsgBox "Function Only Works in LookAhead Sheet!!!"
    Else
        If ws.Name = ActiveWorkbook.ActiveSheet.Name Then
            ActiveSheet.Unprotect "password"
            On Error Resume Next
            If Intersect(Columns("C"), selRows).Count <> IntersectedCells.Count Then
                MsgBox "One or More Rows Selected are P6 Activities" & vbLf & vbLf & "Operation cancelled!", vbCritical
                ActiveSheet.Protect _
                    Password:="password", _
                    DrawingObjects:=True, _
                    Contents:=True, _
                    Scenarios:=True, _
                    AllowFiltering:=True
            Else
                row = InputBox("Enter row number to insert row(s) below")
                If row <> vbNullString Then
                    ActiveSheet.Unprotect "password"
                    For Each rowArea In selRows.Areas
                        rowArea.Cut
                        Rows(row + 1).EntireRow.Select
                        Selection.Insert Shift:=xlDown
                    Next
                    'reprotect sheet
                    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
                End If
            End If
        
        End If
    End If
    
    Application.EnableCancelKey = xlInterrupt
End Sub