Need Macro to move a row of cells down one row

[akey]

I need a macro that when I place the cursor in cell A3 will copy cells A3...F3 to A4...F4. And then if I move the cursor to A6 will copy the cells A6…F6 to A7…F7.


Book1.xls




Any help would be appreciated.

Thank you,

akey

[tom1977]

try something like this

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
Target.Resize(1, 6).Copy Destination:=Target.Offset(1, 0)
End If
End Sub

[DGagnon]

try using the bellow macro, it is based on a double click instead of a single click.

I'm also attaching a workbook to show it working.

this code will also modify your subtotal formula to include the newly entered row.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim intRow, intLen As Integer
    If Target.Column = 1 Then
        intRow = Target.Row
        Range("A" & intRow + 1).Select
        Selection.EntireRow.Insert
        Range("A" & intRow & ":F" & intRow).Select
        Selection.Copy
        Range("A" & intRow + 1).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        intLen = Len(intRow)
        If Right(Range("G" & intRow + 2).Formula, 3 + intLen) = ":G" & intRow & ")" Then
            Range("G" & intRow + 2).Formula = Left(Range("G" & intRow + 2).Formula, Len(Range("G" & intRow + 2).Formula) - 1 - intLen) & intRow + 1 & ")"
        End If
    End If
End Sub

[akey]

I tried cutting and pasting your macro but I keep getting a compile error "Expected End Sub"

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+z
'
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim intRow, intLen As Integer
If Target.Column = 1 Then
intRow = Target.Row
Range("A" & intRow + 1).Select
Selection.EntireRow.Insert
Range("A" & intRow & ":F" & intRow).Select
Selection.Copy
Range("A" & intRow + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
intLen = Len(intRow)
If Right(Range("G" & intRow + 2).Formula, 3 + intLen) = ":G" & intRow & ")" Then
Range("G" & intRow + 2).Formula = Left(Range("G" & intRow + 2).Formula, Len(Range("G" & intRow + 2).Formula) - 1 - intLen) & intRow + 1 & ")"
End If
End If
End Sub


Any thoughts?

Thank you,

akey

[tom1977]

if you want use this code in A3 then A6 then A9 and so on then use this

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
If Target.Row - (3 * Int(Target.Row / 3)) = 0 Then
Target.Resize(1, 6).Copy Destination:=Target.Offset(1, 0)
End If
End If
End Sub

[DGagnon]

instead of entering the macro into a new module under a sub, you need to enter it into the code view of the sheet (just double click on the sheet name in the VB editor) and paste it there

[akey]

Great thanks it is working. The only problem is I don't want a new line inserted I just want those cells copied down so that they are on the same row as the subtotaled amount. I need the row content in yellow on the attached sheet.

Book2.xls

Thanks for all you help,

akey

[DGagnon]

in that case you could use this code instead, still based on a double click.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim intRow As Integer
    If Target.Column = 1 Then
        intRow = Target.Row
        Range("A" & intRow & ":F" & intRow).Select
        Selection.Copy
        Range("A" & intRow + 1).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
    End If
End Sub

[akey]

Thanks DGagnon, it worked perfectly.

akey