T4030_Transfer Specific Cells In Active Row

https://excel-egy.com/forum/t4030
---------------------------------

Sub Transfer_Specific_Cells_In_Active_Row()
    Dim ws As Worksheet, sh As Worksheet, sRow As Long, lr As Long

    Set ws = ThisWorkbook.Worksheets(1)
    Set sh = ThisWorkbook.Worksheets(2)

    Application.ScreenUpdating = False
        If ws.Name <> ActiveSheet.Name Then MsgBox "First Sheet Must Be Activated", vbExclamation: Exit Sub
        sRow = ActiveCell.Row

        If sRow > 1 And Range("A" & sRow) <> "" Then
            lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1

            sh.Range("A" & lr).Value = ws.Range("A" & sRow).Value
            sh.Range("B" & lr).Resize(, 3).Value = ws.Range("E" & sRow).Resize(, 3).Value

            MsgBox "Data In Row " & sRow & " Was Transferred Successfully", vbInformation
        Else
            MsgBox "No Transfer Happened. Make Sure You Are Not In Row 1 And There Is Data In The Active Row", vbExclamation
        End If
    Application.ScreenUpdating = True
End Sub