If Conditions are met, It wil transfer to another worksheet.

[jffryjsphbyn]

Hello.

Please help me to seperate the following. All of these are the found in one worksheet.

On column K if found the word Received and Pending, the whole row will transfer to another sheet named Errors and Others.
On column Z and AA if found the word Error, the whole row will transfer to another sheet named Errors and Others.

Please help!

THanks in advance! :D

[Admin]

Hi

See 'Similar threads' at the bottom of this page. Post back if that doesn't help.

[jffryjsphbyn]

Hi there, I have a different situations compared to other that has a similar posts.

Please help me.


Thanks!

[Admin]

Hi

Untested. Adjust the ranges and sheet names.

Option Explicit

Sub kTest()
    
    Dim wksSource       As Worksheet
    Dim wksDest         As Worksheet
    Dim rngFound        As Range
    Dim LastRow         As Long
    Dim x, i            As Long
    
    Const SourceCol1 = 11   'col K
    Const SearchKey1 = "Received,Pending,aron" 'separated by comma
    Const SourceCol2 = 26   'col Z
    Const SourceCol3 = 27   'col AA
    Const SearchKey2 = "Error"
    
    Set wksSource = Worksheets("Sheet1")    'adjust source sheet name
    Set wksDest = Worksheets("Errors and Others")   'adjust destination sheet name
    
    Application.ScreenUpdating = 0
    With wksSource.Columns(SourceCol1)
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        With .Cells(1, 1).Resize(LastRow)
            x = Split(SearchKey1, ",")
            For i = 0 To UBound(x)
                .AutoFilter 1, x(i)
                On Error Resume Next
                Set rngFound = Nothing
                Set rngFound = .Cells(1).Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(12)
                On Error GoTo 0
                If Not rngFound Is Nothing Then
                    rngFound.EntireRow.Copy wksDest.Cells(SourceCol1 & wksDest.Rows.Count).End(xlUp).Offset(2)
                End If
                .AutoFilter
            Next
        End With
    End With
    
    With wksSource.Columns(SourceCol2)      'second source
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        With .Cells(1, 1).Resize(LastRow)
            x = Split(SearchKey2, ",")
            For i = 0 To UBound(x)
                .AutoFilter 1, x(i)
                On Error Resume Next
                Set rngFound = Nothing
                Set rngFound = .Cells(1).Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(12)
                On Error GoTo 0
                If Not rngFound Is Nothing Then
                    rngFound.EntireRow.Copy wksDest.Cells(SourceCol1 & wksDest.Rows.Count).End(xlUp).Offset(2)
                End If
                .AutoFilter
            Next
        End With
    End With
    
    With wksSource.Columns(SourceCol2)      'third source column
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        With .Cells(1, 1).Resize(LastRow)
            x = Split(SearchKey2, ",")
            For i = 0 To UBound(x)
                .AutoFilter 1, x(i)
                On Error Resume Next
                Set rngFound = Nothing
                Set rngFound = .Cells(1).Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(12)
                On Error GoTo 0
                If Not rngFound Is Nothing Then
                    rngFound.EntireRow.Copy wksDest.Cells(SourceCol1 & wksDest.Rows.Count).End(xlUp).Offset(2)
                End If
                .AutoFilter
            Next
        End With
    End With
    Application.ScreenUpdating = 1
    
End Sub

[jffryjsphbyn]

Hi,

There is nothing happens when I am running the codes. I have completed the necessary requirements to fully run it.

Please help.

[alansidman]

Are you getting error messages? What do they say? Which line is highlighted?