Change code to macro for copy data to other sheet

ste33uka

Active Member
Joined
Jan 31, 2020
Messages
378
Office Version
  1. 2019
Platform
  1. Windows
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
VBA Code:
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
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

rollis13

Active Member
Joined
Jul 30, 2012
Messages
426
Office Version
  1. 2016
Platform
  1. Windows
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:
VBA Code:
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
 
Last edited:
Solution

ste33uka

Active Member
Joined
Jan 31, 2020
Messages
378
Office Version
  1. 2019
Platform
  1. Windows
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:
VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,129,754
Messages
5,638,170
Members
417,011
Latest member
Amaden95

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top