VBA code to Filter data and create a new sheet and transfer data to it

Question

I'm new to VBA for excel, I'm trying to do a multiple filter with four criteria on a column containing either of the following strings (trsf ,trf, transfer, trnsf) that is 4 criteria, but I was only able to do it for two, I can't seem to do it for 4, I manually created a new sheet called Transfers but I want the code to automatically create the new sheet and name it Transfers. Please help modify: to allow four criteria and create a new sheet and rename it and transfer the filtered data to the new sheet ,and restore the DataSheet Back to its default state before the filter.

Sub ActivateJournalsSheet()
Dim wsj As Worksheet
For Each wsj In Worksheets
If wsj.Name <> "DataSheet" Then
wsj.Select
wsj.Application.Run "Transfers"
End If
Next
End Sub
Sub Transfers()
ActiveSheet.Range("$A$1:$H$4630").AutoFilter Field:=2, Criteria1:="=*trsf*", Operator:=xlOr, _
Criteria2:=Array( _
trsfs, _
trnsf, _
transfer), _
Operator:=xlFilterValues
Worksheets.Add.Name = "Transfers"
End Sub

Sub CopyPaste()
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "DataSheet" Then
ws.Select
ws.Application.Run "MacroCopy"
End If
Next
End Sub

Sub MacroCopy()
Range("A1:H4630").Select
Selection.Copy
Sheets("Transfers").Paste
End Sub

Thanks Dan, i had to delete this because the strings 'trans' and 'trsf' appear as part of other strings not just as the only content of cells.

'make sure that trans or trsf exists in the check range Set TestTRANS = `CheckRng.Find(What:="trans", LookIn:=xlValues, LookAt:=xlWhole) Set TestTRSF = CheckRng.Find(What:="trsf", LookIn:=xlValues, LookAt:=xlWhole) If TestTRANS Is Nothing And TestTRSF Is Nothing Then MsgBox ("Could not find ""trans"" or ""trsf"" in column B, exiting!") Exit Sub End If`

I also added the second criteria as an array but it'd giving a syntax error . .. the code runs fine with the two initial two criteria , but I want to add trfs and trnsf

With DataRng
    .AutoFilter Field:=2, Criteria1:="=*trsf*", Operator:=xlOr, Criteria2:=Array( _trfs, _trnsf), _Operator:=xlFilterValues
End With

Answer 1

I think the code below does everything you're looking for:

Option Explicit
Sub BringItAllTogether()

Dim DataSheet As Worksheet, TransfersSheet As Worksheet
Dim DataRng As Range, CheckRng As Range, _
    TestTRANS As Range, TestTRSF As Range, _
    CopyRng As Range, PasteRng As Range

'make sure the data sheet exists
If Not DoesSheetExist("DataSheet", ThisWorkbook) Then
    MsgBox ("No sheet named ""DataSheet"" found, exiting!")
    Exit Sub
End If

'assign the data sheet, data range and check range
Set DataSheet = ThisWorkbook.Worksheets("DataSheet")
Set DataRng = DataSheet.Range("$A$1:$H$4630")
Set CheckRng = DataSheet.Range("$B$1:$B$4630")

'make sure that trans or trsf exists in the check range
Set TestTRANS = CheckRng.Find(What:="trans", LookIn:=xlValues, LookAt:=xlWhole)
Set TestTRSF = CheckRng.Find(What:="trsf", LookIn:=xlValues, LookAt:=xlWhole)
If TestTRANS Is Nothing And TestTRSF Is Nothing Then
    MsgBox ("Could not find ""trans"" or ""trsf"" in column B, exiting!")
    Exit Sub
End If

'apply autofilter and create copy range
With DataRng
    .AutoFilter Field:=2, Criteria1:="=*trsf*", Operator:=xlOr, Criteria2:="=*trans*"
End With
Set CopyRng = DataRng.SpecialCells(xlCellTypeVisible)
DataSheet.AutoFilterMode = False

'make sure a sheet named transfers doesn't already exist, if it does then delete it
If DoesSheetExist("Transfers", ThisWorkbook) Then
    MsgBox ("Whoops, ""Transfers"" sheet already exists. Deleting it!")
    Set TransfersSheet = Worksheets("Transfers")
    TransfersSheet.Delete
End If

'create transfers sheet
Set TransfersSheet = Worksheets.Add
TransfersSheet.Name = "Transfers"

'paste the copied range to the transfers sheet
CopyRng.Copy
TransfersSheet.Range("A1").PasteSpecial Paste:=xlPasteAll

End Sub

Public Function DoesSheetExist(SheetName As String, BookName As Workbook) As Boolean
    Dim obj As Object
    On Error Resume Next
    'if there is an error, sheet doesn't exist
    Set obj = BookName.Worksheets(SheetName)
    If Err = 0 Then
        DoesSheetExist = True
    Else
        DoesSheetExist = False
    End If
    On Error GoTo 0
End Function