Edward Pamias
asked on
I need Excel macro modified to filter remote2office and filter out duplicates.
I need a macro modified to filter out(needs to be added) remote2office and filter out duplicates in column B, title of the row with the possible duplicates is "User Reference Number"
Sub CopyFilteredRow2()
Dim SrcWs As Worksheet, NewSh As Worksheet
Dim SrcLR As Long
Dim j As Long
Dim Crit(2) As String
Dim StrIF As String
Dim RngFilter As Range
With Application
.ScreenUpdating = False
.DisplayStatusBar = True
.StatusBar = "!!! Please Be Patient...Updating Records !!!"
.EnableEvents = False
.Calculation = xlManual
End With
Set SrcWs = ActiveSheet
SrcLR = SrcWs.Range("A" & Rows.Count).End(xlUp).Row
Crit(0) = "*Asset Verification*"
Crit(1) = "*R2O*"
Crit(2) = "*Project*"
With SrcWs
.AutoFilterMode = False
.Range("L1").Value = "Temp"
For j = 2 To SrcLR
StrIF = "=if(or(isnumber(search(" & Chr(34) & Crit(0) & Chr(34) & ",h" & j & ")),isnumber(search(" & Chr(34) & Crit(1) & Chr(34) _
& ",h" & j & ")),isnumber(search(" & Chr(34) & Crit(2) & Chr(34) & ",h" & j & "))),999,0)"
.Range("l" & j).Formula = StrIF
Next j
End With
Set RngFilter = SrcWs.Range("A1:L" & SrcLR)
With RngFilter
.AutoFilter Field:=12, Criteria1:="0", Operator:=xlFilterValues
.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add.Paste
End With
SrcWs.Columns(12).Delete
ActiveSheet.Name = "FilteredSheet"
Set NewSh = Worksheets("FilteredSheet")
Application.CutCopyMode = False
If SrcWs.AutoFilterMode = True Then SrcWs.AutoFilterMode = False
NewSh.Activate
NewSh.Columns(12).Delete
NewSh.Columns.AutoFit
NewSh.Range("A2").Select
ActiveWindow.FreezePanes = True
With Application
.ScreenUpdating = True
.DisplayStatusBar = True
.StatusBar = False
.EnableEvents = True
.Calculation = xlAutomatic
End With
End Sub
Sorry Edward, please change this line:
Set RngFilter = SrcWs.Range("A1:S" & SrcLR)
to
Set RngFilter = SrcWs.Range("A1:L" & SrcLR)
Set RngFilter = SrcWs.Range("A1:S" & SrcLR)
to
Set RngFilter = SrcWs.Range("A1:L" & SrcLR)
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
This update worked perfectly. Thank you!
You're Welcome Edward! Pleased to help.
Please try below:
Open in new window