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?