charchar001
New Member
- Joined
- Jun 24, 2019
- Messages
- 9
Hey Guys,
I am trying to create a code that does multiple filters and copies data depending on items from a sheet.
There are two sheets; one IPSWB where it contains the Parts to be filtered, and the other is ACSWB where the logic is derived from for filtering.
My Issue arises when I need to search column B in ACSWB, for a certain feature (sub Customefeature first line).
I define what ACSWB and IPSWB are in the test macro and the DIM's are public. Is there a way to keep the defined workbooks attached to those titles? Or is there a better way of doing the search?
I can't define the workbooks again as each time the tool is run the file name/locations will be different.
I was forced to run a second sub as the For loop wasn't running in the main code.
I am trying to create a code that does multiple filters and copies data depending on items from a sheet.
There are two sheets; one IPSWB where it contains the Parts to be filtered, and the other is ACSWB where the logic is derived from for filtering.
My Issue arises when I need to search column B in ACSWB, for a certain feature (sub Customefeature first line).
I define what ACSWB and IPSWB are in the test macro and the DIM's are public. Is there a way to keep the defined workbooks attached to those titles? Or is there a better way of doing the search?
I can't define the workbooks again as each time the tool is run the file name/locations will be different.
VBA Code:
Public IPSFile As Variant
Public ACSFile As Variant
Public ToolWB As Workbook
Public ACSWB As Workbook
Public IPSWB As Workbook
Public SrchRng As Range, cel As Range
Sub Test_Macro()
'
' Test_Macro Macro
'
Dim IPSFile As Variant
Dim ACSFile As Variant
Dim ToolWB As Workbook
Dim ACSWB As Workbook
Dim IPSWB As Workbook
Dim SrchRng As Range, cel As Range
Dim filename As String
Set ToolWB = ThisWorkbook
Set SrchRng = Range("B13:B2000")
'Open ACS File
ACSFile = Application.GetOpenFilename _
(Title:="Please choose the ACSfile to open", _
FileFilter:="Excel Files *.xls* (*.xls*),")
Workbooks.Open filename:=ACSFile
Set ACSWB = ActiveWorkbook
' Open IPS downloaded file
IPSFile = Application.GetOpenFilename _
(Title:="Please choose a IPSfile to open", _
FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
Workbooks.Open filename:=IPSFile
Set IPSWB = ActiveWorkbook
'Unfreeze panes
ActiveWindow.FreezePanes = False
'Delete Row
Rows("12:12").Select
Selection.Delete Shift:=xlUp
Rows("2:9").Select
Selection.Clear
'fit table
Cells.Select
Cells.EntireColumn.AutoFit
ACSWB.Activate
If [B9] = "CE MARK" Then
IPSWB.Activate
'create filter for Pipe assy that are PED required
Range("A12:F12").Select
Selection.AutoFilter
ActiveSheet.Range("$A$12:$F$10000").AutoFilter Field:=3, Criteria1:= _
"=*Pipe Assy*", Operator:=xlAnd
ActiveSheet.Range("$A$12:$F$10000").AutoFilter Field:=1, Criteria1:="=*P*", _
Operator:=xlOr
Selection.CurrentRegion.Select
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
'create new sheet for Pipes and hoses
Sheets.Add After:=ActiveSheet
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Pipes&Hoses"
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
'Add the Meetering Valves and Shutoff Valves
Sheets("IPSReport").Select
ActiveSheet.Range("$A$12:$F$10000").AutoFilter Field:=3
ActiveSheet.Range("$A$12:$F$10000").AutoFilter Field:=1
ActiveSheet.Range("$A$12:$F$10000").AutoFilter Field:=6, Criteria1:="=*FCE*" _
, Operator:=xlOr
Selection.CurrentRegion.Select
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "Devices"
Sheets("Devices").Select
ActiveSheet.Paste
Sheets("IPSReport").Select
ActiveSheet.Range("$A$12:$F$10000").AutoFilter Field:=6, Criteria1:="=*ASY2120*" _
, Operator:=xlOr, Criteria2:="=*ASY2124*"
Selection.CurrentRegion.Select
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Sheets("Devices").Select
Range("A1").End(xlDown).Offset(1).Select
ActiveSheet.Paste
'Check if there is a CF 0000000885 for Flex hoses to be pressure tested and CF0 0000000741 for Pressure transmitters records
customfeatures
ElseIf [B9] <> "CE MARK" Then
customfeatures
End If
End Sub
Sub customfeatures()
ACSWB.Activate
For Each cel In SrchRng
If InStr(1, cel.Value, "0000000885") > 0 Then
IPSWB.Activate
Sheets("IPSReport").Select
ActiveSheet.Range("$A$12:$F10000").AutoFilter Field:=3, Criteria1:= _
"=*hose assy*", Operator:=xlAnd
ActiveSheet.Range("$A$12:$F$10000").AutoFilter Field:=1, Criteria1:="=19*", _
Operator:=xlAnd
Selection.CurrentRegion.Select
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Sheets("Pipes&Hoses").Select
Range("A1").End(xlDown).Offset(1).Select
ActiveSheet.Paste
ElseIf InStr(1, cel.Value, "0000000741") > 0 Then
IPSWB.Activate
Sheets("IPSReport").Select
ActiveSheet.Range("$A$12:$F$10000").AutoFilter Field:=3
ActiveSheet.Range("$A$12:$F$10000").AutoFilter Field:=1
ActiveSheet.Range("$A$12:$F$10000").AutoFilter Field:=6, Criteria1:="=*PT*" _
, Operator:=xlOr, Criteria2:="=*PDT*"
Selection.CurrentRegion.Select
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "Devices"
Sheets("Devices").Select
Range("A1").End(xlDown).Offset(1).Select
ActiveSheet.Paste
End If
Next cel
End Sub
I was forced to run a second sub as the For loop wasn't running in the main code.