VBA to copy active cell as well as 3 cells next to it

[MariaJohnson88]

Hi

I am looking for a macro that will assist me in copying active cell in column A, as well as corresponding 3 columns (B:D) to a different sheet
I also have a message box that prompts who is pulling the stock
What I have so far:




Dim i As String


ActiveCell.copy
Sheets("Stock tracking").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Do
i = Application.InputBox("Enter Name", "Name Box", , , , , , 2)
Sheets("Stock tracking").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = i

If i = vbNullString Then

MsgBox "Invalid Entry ", vbExclamation
End If
Loop While i = vbNullString

ActiveCell.Clear



End Sub

 

[HaHoBe]

Ho MariaJohnson88,

what about

Public Sub MrE_1230406_170330F()
' https://www.mrexcel.com/board/threads/vba-to-copy-active-cell-as-well-as-3-cells-next-to-it.1230406/

Dim strAns As String
Dim lngNext As Long
Dim rngCopy As Range

With ActiveCell
  If .Column <> 1 Then Exit Sub
  If .Value = "" Then Exit Sub
  Set rngCopy = .Resize(1, 4)
End With
rngCopy.Copy
With Sheets("Stock tracking")
  lngNext = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
  .Range("A" & lngNext).PasteSpecial xlPasteValues
  Do
    strAns = Application.InputBox("Enter Name", "Name Box", , , , , , 2)
    If strAns = vbNullString Then
      MsgBox "Invalid Entry ", vbExclamation
    ElseIf strAns = False Then
      'user choose Cancel, what to do?
      .Range("A" & lngNext).Resize(1, 4).Clear
      GoTo end_here
    Else
      .Range("E" & lngNext).Value = strAns
    End If
  Loop While strAns = vbNullString
End With

rngCopy.Clear

end_here:
Application.CutCopyMode = False
Set rngCopy = Nothing

End Sub

Ciao,
Holger

 

[rlv01]

It sounds like what you want is for cells A:B in what ever row the active cell is in to be copied? In that case perhaps replace ActiveCell.Copy with ActiveCell.EntireRow.Range("A1:D1").Copy.

Also if it is your intent to make the user enter their name, I recommend doing that first thing. Example:

Sub Test()
    Dim i As String

    Do
        i = Trim(Application.InputBox("Enter Name", "Name Box", , , , , , 2))
        Select Case i
        Case "False"                                  'User cancelled
            Exit Sub
        Case vbNullString
            MsgBox "Please enter your name", vbExclamation
        End Select
    Loop While i = vbNullString
    
    'ActiveCell.Copy
    ActiveCell.EntireRow.Range("A1:D1").Copy
    Sheets("Stock tracking").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    'ActiveCell.Clear
    ActiveCell.EntireRow.Range("A1:D1").Clear
End Sub

(Tip: when posting code, please try to use 'code tags' to format the code as I have done above

How to Post Your VBA Code

as it makes the code easier to read.)

 

[HaHoBe]

Hi rlv01,

regarding Also if it is your intent to make the user enter their name: why does your code ask for it but does not insert the return into Sheet Stock tracking?

BTW: maybe use Environ("UserName") which returns the name of the person logged into the computer instead of asking for it.

Holger

 

[rlv01]

why does your code ask for it but does not insert the return into Sheet Stock tracking?

LOL, that would be termed a "mistake" . I forgot to re-add the needed statement when I was rearranging things.

    'ActiveCell.Copy
    ActiveCell.EntireRow.Range("A1:D1").Copy
    Sheets("Stock tracking").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Sheets("Stock tracking").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = i  '<-- add

BTW: maybe use Environ("UserName") which returns the name of the person logged into the computer instead of asking for it.

That's how I'd do it, but until the OP provides feedback, we can only guess at whether it meets the requirement.

 

[HaHoBe]

Hi rkv01,

sorry to disturb again but adding the contents to Column B when data has been inserted from A to D would overwrite the contents in Column B - instead you should do so in Column E or insert into Column B.

If I spot the opening post I think I would go a different way to show a UserForm with either Checkboxes to identify the personal or a Listbox or CombBox to do so and enter the appropriate name when a CommandButton is pressed. Advantage would be that the names will always be the same, no typos (my favourite when entering data directly)...

Holger

 

[MariaJohnson88]

Ho MariaJohnson88,

what about

Public Sub MrE_1230406_170330F()
' https://www.mrexcel.com/board/threads/vba-to-copy-active-cell-as-well-as-3-cells-next-to-it.1230406/

Dim strAns As String
Dim lngNext As Long
Dim rngCopy As Range

With ActiveCell
  If .Column <> 1 Then Exit Sub
  If .Value = "" Then Exit Sub
  Set rngCopy = .Resize(1, 4)
End With
rngCopy.Copy
With Sheets("Stock tracking")
  lngNext = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
  .Range("A" & lngNext).PasteSpecial xlPasteValues
  Do
    strAns = Application.InputBox("Enter Name", "Name Box", , , , , , 2)
    If strAns = vbNullString Then
      MsgBox "Invalid Entry ", vbExclamation
    ElseIf strAns = False Then
      'user choose Cancel, what to do?
      .Range("A" & lngNext).Resize(1, 4).Clear
      GoTo end_here
    Else
      .Range("E" & lngNext).Value = strAns
    End If
  Loop While strAns = vbNullString
End With

rngCopy.Clear

end_here:
Application.CutCopyMode = False
Set rngCopy = Nothing

End Sub

Ciao,
Holger

Hi Holger,

With some minor tweaks this worked perfectly, because it allows for provision if active cell isn't in column A

I can't thank you enough.