CODEWITHSUNDEEP
excelvba
John Diro
John Diro

Reputation: 21

Excel VBA code to copy a range of cells in a row and paste in a different sheet but same row/range, when the value on 1st cell changes

I need a vba code to copy a range of cells in a row (eg:Sheet1 ! A2:I2), and paste it in a different sheet (eg "Sheet2") but same row (i.e.Sheet 2! A2:I2), need this to happen automatically when a value in the column "K2" is changed, note that K2-K100 contain values that can change.

So if K3 of sheet 1 changes, then A3:I3 of Sheet 1 should automatically be copied to A3:I3 of Sheet 2, likewise if K4 of sheet 1 changes, then A4:I4 of sheet 1 should automatically be copied to A4:I4 of sheet 2

Any kind suggestions;

PS: New to vba work, apologies if I haven't written out my request properly

Upvotes: 1

Views: 376

Answers (1)

VBasic2008
VBasic2008

Reputation: 54807

"Worksheet_Change": Automatic (Event Driven) Copying

  • Copy this code to the worksheet being monitored and change the values in the constants section particularly 'strPaste' i.e. the name of the worksheet to be written to.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:  If data changes in cells of a specified column in the worksheet    '
'           containing this code, automatically (event driven) copies          '
'           the row ranges determined by the rows of the changed cells         '
'           and other specified conditions to the same row ranges on another   '
'           specified worksheet.                                               '
' Remarks:  This worksheet will be monitored, another will be written to.      '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Worksheet_Change(ByVal Target As Range)

    ' Constants (change to fit your needs)
    Const strPaste As String = "Sheet2"   ' Paste WorkSheet Name
    Const FR As Long = 2                  ' First Row Number
    Const FC As Long = 1                  ' First Column Number
    Const LC As Long = 9                  ' Last Column Number
    Const CC As Long = 11                 ' Criteria Column Number

    Dim wsPaste As Worksheet              ' Paste Worksheet
    Dim rngC As Range                     ' Criteria Column Range
    Dim rngCC As Range                    ' Current Criteria Cell Range
    Dim LR As Long                        ' Last Row Number
    Dim RCO as long                       ' Resize ColumnSize

    ' Prevent events staying disabled if something goes wrong.
    On Error GoTo ProcedureExit

    ' Caclulate Last Row Number (LR).
    LR = Me.Cells(Me.Rows.Count, CC).End(xlUp).Row
    ' Initialize Criteria Column Range (rngC).
    Set rngC = Me.Cells(FR, CC).Resize(LR - FR + 1)

    ' Check if there has been a change in Criteria Column Range (rngC).
    If Not Intersect(Target, rngC) Is Nothing Then

        On Error Resume Next
            ' Initialize Paste Worksheet (wsPaste).
            Set wsPaste = Worksheets(strPaste)
            ' Check if Paste Worksheet (wsPaste) was initialized.
            If wsPaste Is Nothing Then GoTo WorksheetError
        On Error GoTo ProcedureExit

        ' Calculate Resize ColumnSize (RCO).
        RCO = LC - FC + 1

        ' Disable events to speed up write operations.
        Application.EnableEvents = False

        ' Loop through found Criteria Cells (rngCC).
        For Each rngCC In Intersect(Target, rngC)
            ' Copy values from this worksheet (Me) to Paste Worksheet (wsPaste).
            wsPaste.Cells(rngCC.Row, FC).Resize(, RCO).Value _
              = Me.Cells(rngCC.Row, FC).Resize(, RCO).Value
        Next

    End If

ProcedureExit:
    ' Enable events.
    Application.EnableEvents = True

Exit Sub

WorksheetError:
    MsgBox "There is no worksheet named '" & strPaste & "'. " & vbCrLf _
      & "Change 'Paste WorkSheet Name' ('strPaste') in VBA (Alt+F11).", _
      vbCritical, "Wrong Worksheet Name"
    GoTo ProcedureExit

End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Upvotes: 1

Related Questions