Macro, if words or numbers found copy rows

[ste33uka]

Hi would anyone have a macro that would copy the whole row and the 3 rows under to the next available row to a worksheet called "INTERESTS"
If the word "try" or the numbers 1,2,3 is found in column "J ", or the words " trs " or " trp "is found in column "Z"
In column "Z" the words "trs" and "trp" are made via forumla =IF(D1="yes","trs","trp")
Could it run on 50 sheets,the sheets are named 1,2,3,4,5,6,7 and so on
Example Z4 = trs , rows Z4 to Z7 would copy to sheet "INTERESTS"
Thanks

 

[Sequoyah]

Hi ste33uka,
try this code, assuming your workbook contains a sheet named INTERESTS and the other sheets numbered 1 to 50

Sub test20210701()
'https://www.mrexcel.com/board/threads/macro-if-words-or-numbers-found-copy-rows.1175294/
    
    Dim wKS As Worksheet, wKSINT As Worksheet
    Dim i As Integer
    Dim nextFree As Integer
    
    Set wKSINT = ThisWorkbook.Sheets("INTERESTS")
    Application.ScreenUpdating = False
    
    For Each wKS In ThisWorkbook.Sheets
        
        If wKS.Name <> "INTERESTS" Then
            
            For i = 1 To wKS.Cells(Rows.Count, "J").End(xlUp).Row
                
                nextFree = wKSINT.Cells.Find(What:="*", _
                           After:=wKSINT.Range("A1"), _
                           Lookat:=xlPart, _
                           LookIn:=xlFormulas, _
                           SearchOrder:=xlByRows, _
                           SearchDirection:=xlPrevious, _
                           MatchCase:=False).Row + 1
                
                If wKS.Cells(i, 10).Value = "1" Or wKS.Cells(i, 10).Value = "2" Or wKS.Cells(i, 10).Value = "3" Or _
                   wKS.Cells(i, 10).Value = "try" Or wKS.Cells(i, 26).Value = "trs" Or wKS.Cells(i, 26).Value = "trp" Then
                
                wKS.Range(i & ":" & i).Resize(4).Copy wKSINT.Range(nextFree & ":" & nextFree)
            End If
            
        Next i
    End If
    
Next wKS

Application.ScreenUpdating = True

End Sub

 

[ste33uka]

Hi ste33uka,
try this code, assuming your workbook contains a sheet named INTERESTS and the other sheets numbered 1 to 50

Sub test20210701()
'https://www.mrexcel.com/board/threads/macro-if-words-or-numbers-found-copy-rows.1175294/
   
    Dim wKS As Worksheet, wKSINT As Worksheet
    Dim i As Integer
    Dim nextFree As Integer
   
    Set wKSINT = ThisWorkbook.Sheets("INTERESTS")
    Application.ScreenUpdating = False
   
    For Each wKS In ThisWorkbook.Sheets
       
        If wKS.Name <> "INTERESTS" Then
           
            For i = 1 To wKS.Cells(Rows.Count, "J").End(xlUp).Row
               
                nextFree = wKSINT.Cells.Find(What:="*", _
                           After:=wKSINT.Range("A1"), _
                           Lookat:=xlPart, _
                           LookIn:=xlFormulas, _
                           SearchOrder:=xlByRows, _
                           SearchDirection:=xlPrevious, _
                           MatchCase:=False).Row + 1
               
                If wKS.Cells(i, 10).Value = "1" Or wKS.Cells(i, 10).Value = "2" Or wKS.Cells(i, 10).Value = "3" Or _
                   wKS.Cells(i, 10).Value = "try" Or wKS.Cells(i, 26).Value = "trs" Or wKS.Cells(i, 26).Value = "trp" Then
               
                wKS.Range(i & ":" & i).Resize(4).Copy wKSINT.Range(nextFree & ":" & nextFree)
            End If
           
        Next i
    End If
   
Next wKS

Application.ScreenUpdating = True

End Sub

 

[ste33uka]

Hi thanks, but i get run time error 6
overflow
highlights in yellow line
For i = 1 To wKS.Cells(Rows.Count, "J").End(xlUp).Row

 

[ste33uka]

thanks for help, going to find a different way around the problem,
no more help needed here

 

[Sequoyah]

Hi ste33uka,
I’m glad you solved your problem, in any case I think it is enough to replace this line

Dim i As Integer

with

Dim i As Long