Change code to macro for copy data to other sheet

[ste33uka]

I have the following code that copies whole row and the 3 rows under to a worksheet called "INTERESTS" when a number of letter is found in column E.
Could someone please change it so it could be run as a macro for a workbook with 50 sheet? worksheet names are 1,2,3,4,5,6 and so on
Thanks

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim nr As Long 'next row
    Dim ws As Worksheet
    
    If Target.Column = 5 And Target.Cells.Count = 1 Then
        Select Case LCase(Trim(Target.Value))

            Case "1"
                Set ws = Worksheets("INTERESTS")
            Case "2"
               Set ws = Worksheets("INTERESTS")
            Case "3"
                Set ws = Worksheets("INTERESTS")
             Case "d2"
                Set ws = Worksheets("INTERESTS")
              Case "d3"
                Set ws = Worksheets("INTERESTS")
      
                
        End Select
        
        If Not ws Is Nothing Then
            nr = ws.Range("A" & Rows.Count).End(xlUp).Row + 1 'get next empty row on data sheet
            Rows(Target.Row & ":" & Target.Row + 3).Copy 'copy the row and the next 3 rows
            ws.Rows(nr).PasteSpecial xlPasteValues 'paste the values in the next available row
        End If
    End If
End Sub

 

[rollis13]

You can use event Workbook_SheetChange in ThisWorkbook module for all sheets instead of event Worksheet_Change in every single sheet.
Delete your actual 'Worksheet_Change' macro and use this modified version to be pasted in your 'ThisWorkbook' vba pane:

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) '<= changed
    Dim nr     As Long                            'next row
    Dim ws     As Worksheet
    If Sh.Name = "INTERESTS" Then Exit Sub        '<= added (macro not necessary for this sheet)
    If Target.Column = 5 And Target.Cells.Count = 1 Then
        Select Case LCase(Trim(Target.Value))
            Case "1", "2", "3", "d2", "d3"        '<= changed
                Set ws = Worksheets("INTERESTS")
        End Select
        If Not ws Is Nothing Then
            Application.ScreenUpdating = False    '<= added (to avoid screen flickering)
            Application.EnableEvents = False      '<= added (to avoid redundancy when pasting)
            nr = ws.Range("A" & Rows.Count).End(xlUp).Row + 1 'get next empty row on data sheet
            Rows(Target.Row & ":" & Target.Row + 3).Copy 'copy the row and the next 3 rows
            ws.Rows(nr).PasteSpecial xlPasteValues 'paste the values in the next available row
            Application.EnableEvents = True       '<= added
            Application.ScreenUpdating = True     '<= added
            Application.CutCopyMode = False       '<= added (to clear clipboard)
        End If
    End If
End Sub

 

[ste33uka]

You can use event Workbook_SheetChange in ThisWorkbook module for all sheets instead of event Worksheet_Change in every single sheet.
Delete your actual 'Worksheet_Change' macro and use this modified version to be pasted in your 'ThisWorkbook' vba pane:

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) '<= changed
    Dim nr     As Long                            'next row
    Dim ws     As Worksheet
    If Sh.Name = "INTERESTS" Then Exit Sub        '<= added (macro not necessary for this sheet)
    If Target.Column = 5 And Target.Cells.Count = 1 Then
        Select Case LCase(Trim(Target.Value))
            Case "1", "2", "3", "d2", "d3"        '<= changed
                Set ws = Worksheets("INTERESTS")
        End Select
        If Not ws Is Nothing Then
            Application.ScreenUpdating = False    '<= added (to avoid screen flickering)
            Application.EnableEvents = False      '<= added (to avoid redundancy when pasting)
            nr = ws.Range("A" & Rows.Count).End(xlUp).Row + 1 'get next empty row on data sheet
            Rows(Target.Row & ":" & Target.Row + 3).Copy 'copy the row and the next 3 rows
            ws.Rows(nr).PasteSpecial xlPasteValues 'paste the values in the next available row
            Application.EnableEvents = True       '<= added
            Application.ScreenUpdating = True     '<= added
            Application.CutCopyMode = False       '<= added (to clear clipboard)
        End If
    End If
End Sub

Thanks alot for that, maybe that will be better than running a macro, thanks

 

[rollis13]

Glad I was able to help.