ayyappan80
05-25-2020, 04:15 AM
Hi I am using this code range of specific cell to filter active worksheet and save to new worksheet. Currently the code is working fine. Now i want to modify the code, select Range as well as Input box (Single input typed by user, text,number or Date) can someone help me to modify the code.
Sub CopyPaste_SPecific_Filter()
'filter specific data'
MsgBox " Please ensure Run this Code from Sheet Where do you want to Filter"
Set sh1 = Sheets(ActiveSheet.Name)
Set Dest = Sheets.Add(After:=Sheets(Sheets.Count)).Range("B4")
sh1.Activate
Set selectcrit = Application.InputBox("select the criteria range", Type:=8)
RngCrit = selectcrit.Worksheet.Name & "!" & selectcrit.Address
With ActiveSheet
y = Application.InputBox("select the HEADER column to be filtered", Type:=8).Address(0, 0)
Set oStart = Range(y).End(xlToLeft)
Set oEnd = Range(y).End(xlToRight).End(xlDown)
Set TblRng = Range(oStart, oEnd.Offset(0, 1))
If .AutoFilterMode Then TblRng.AutoFilter
tCol = TblRng.Columns.Count
TblRng.Columns(tCol) = "=match(" & y & "," & RngCrit & ",0)"
TblRng.Columns(tCol).Value = TblRng.Columns(tCol).Value
TblRng.AutoFilter Field:=tCol, Criteria1:="<>#N/A", Operator:=xlAnd
Range(TblRng.Columns(1), TblRng.Columns(tCol - 1)).Copy Destination:=Dest
TblRng.AutoFilter
TblRng.Columns(tCol).ClearContents
End With
End Sub
Sub CopyPaste_SPecific_Filter()
'filter specific data'
MsgBox " Please ensure Run this Code from Sheet Where do you want to Filter"
Set sh1 = Sheets(ActiveSheet.Name)
Set Dest = Sheets.Add(After:=Sheets(Sheets.Count)).Range("B4")
sh1.Activate
Set selectcrit = Application.InputBox("select the criteria range", Type:=8)
RngCrit = selectcrit.Worksheet.Name & "!" & selectcrit.Address
With ActiveSheet
y = Application.InputBox("select the HEADER column to be filtered", Type:=8).Address(0, 0)
Set oStart = Range(y).End(xlToLeft)
Set oEnd = Range(y).End(xlToRight).End(xlDown)
Set TblRng = Range(oStart, oEnd.Offset(0, 1))
If .AutoFilterMode Then TblRng.AutoFilter
tCol = TblRng.Columns.Count
TblRng.Columns(tCol) = "=match(" & y & "," & RngCrit & ",0)"
TblRng.Columns(tCol).Value = TblRng.Columns(tCol).Value
TblRng.AutoFilter Field:=tCol, Criteria1:="<>#N/A", Operator:=xlAnd
Range(TblRng.Columns(1), TblRng.Columns(tCol - 1)).Copy Destination:=Dest
TblRng.AutoFilter
TblRng.Columns(tCol).ClearContents
End With
End Sub