Auto filter with more than 2 criteria with wildcards - excel

I'm using the following code in a Macro:
Sub Macro2()
Sheets("Bill").Select
Range("A2:AA2").Select
Rows("2:2").Select
Selection.AutoFilter
Range("T2").Select
ActiveSheet.Range("$A$2:$AA$111").AutoFilter Field:=20, Criteria1:=Array("=*Base ch*", _
"=*Service*", "=*Supply Ch*", "=*Customer*", "=*Analyst*"), Operator:=xlFilterValues
End Sub
It's not showing any error and when I use only 2 criteria It works perfect.
The issue is when I try more than 2. It doesn't show anything.
I tried the operator OR but I think that only works with 2 criteria.
Any suggestions?

Instead of AutoFilter, try Advanced Filter when dealing with multiple wildcard criteria. All you need is to either have a sheet with those criteria listed along with wildcard or create the criteria sheet programmatically and delete it in the end.
The below code will create a criteria sheet programmatically and list all your criteria in column A starting from Row2 and A1 on criteria sheet will contain the column header from your data sheet.
Sub FilterWithMultipleWildcardCriteria()
Dim ws As Worksheet, wsCriteria As Worksheet
Dim strCriterai
Dim lr As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = Sheets("Bill")
If ws.FilterMode Then ws.ShowAllData
lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error Resume Next
Set wsCriteria = Sheets("Criteria")
wsCriteria.Cells.Clear
On Error GoTo 0
If wsCriteria Is Nothing Then
Set wsCriteria = Sheets.Add
wsCriteria.Name = "Criteria"
End If
wsCriteria.Range("A1").Value = ws.Range("T2").Value
strcriteria = Array("*Base ch*", "*Service*", "*Supply Ch*", "*Customer*", "*Analyst*")
wsCriteria.Range("A2").Resize(UBound(strcriteria) + 1).Value = Application.Transpose(strcriteria)
ws.Range("A2:AA" & lr).AdvancedFilter xlFilterInPlace, wsCriteria.Range("A1").CurrentRegion
wsCriteria.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Related

Copy and Paste Loop based on Cell value

Created a macro below thanks to help from another that works.
Basically, it takes the value of the cell in column A and, if a sheet doesn't exist with that cells name, creates it. Then it pastes all rows of data that have the corresponding cell value to that sheet. Ie. if a cell contains the following:
column a column b
dc00025 data value
If dc00025 doesn't exist, it'll make the sheet. And paste all rows with dc00025 in A.
This works perfectly. However, I noticed when you run this macro after a sheet has already been created, for some reason it adds thousands of columns dramatically slowing down excel.
To fix this, would it be possible to modify the script to only copy columns b:o rather tahnt he entire row? Pasting them starting at A3 would be preferable but I'm not sure how to fix that.
Thanks in advance.
Sub CopyCodes()
Application.ScreenUpdating = False
Dim rCell As Range
Dim lastrow As Long
lastrow = Sheets("Data").UsedRange.Rows.Count
For Each rCell In Worksheets("Data").Range("A2:A" & lastrow).SpecialCells(xlCellTypeConstants)
If Not SheetExists(rCell.Value) Then
With Worksheets.Add(, Worksheets(Worksheets.Count))
.Name = rCell.Value
End With
End If
Worksheets("Data").Rows(1).EntireRow.Copy Worksheets(rCell.Value).Rows(1)
Worksheets(rCell.Value).Range("A" & Rows.Count).End(xlUp)(2).EntireRow.Value = _
rCell.EntireRow.Value
Next rCell
Application.ScreenUpdating = True
End Sub
Function SheetExists(wsName As String)
On Error Resume Next
SheetExists = Worksheets(wsName).Name = wsName
End Function
Suggested fix:
Sub CopyCodes()
Application.ScreenUpdating = False
Dim rCell As Range
Dim lastrow As Long
Dim shtData as worksheet, shtDest as worksheet
Dim sheetName as string
set shtData=worksheets("Data")
lastrow = shtData.cells(rows.count,1).end(xlup).row
For Each rCell In shtData.Range("A2:A" & lastrow).SpecialCells(xlCellTypeConstants)
sheetName = rCell.Value
If Not SheetExists(sheetName) Then
set shtDest = Worksheets.Add(, Worksheets(Worksheets.Count))
shtDest.Name = sheetName
shtData.Rows(1).EntireRow.Copy shtDest.Rows(1)
Else
set shtDest = Worksheets(sheetName)
End If
shtDest.Range("A" & Rows.Count).End(xlUp).offset(1,0).EntireRow.Value = _
rCell.EntireRow.Value
Next rCell
Application.ScreenUpdating = True
End Sub

VBA code to Filter data and create a new sheet and transfer data to it

I'm new to VBA for excel, I'm trying to do a multiple filter with four criteria on a column containing either of the following strings (trsf ,trf, transfer, trnsf) that is 4 criteria, but I was only able to do it for two, I can't seem to do it for 4,
I manually created a new sheet called Transfers but I want the code to automatically create the new sheet and name it Transfers. Please help modify: to allow four criteria and create a new sheet and rename it and transfer the filtered data to the new sheet ,and restore the DataSheet Back to its default state before the filter.
Sub ActivateJournalsSheet()
Dim wsj As Worksheet
For Each wsj In Worksheets
If wsj.Name <> "DataSheet" Then
wsj.Select
wsj.Application.Run "Transfers"
End If
Next
End Sub
Sub Transfers()
ActiveSheet.Range("$A$1:$H$4630").AutoFilter Field:=2, Criteria1:="=*trsf*", Operator:=xlOr, _
Criteria2:=Array( _
trsfs, _
trnsf, _
transfer), _
Operator:=xlFilterValues
Worksheets.Add.Name = "Transfers"
End Sub
Sub CopyPaste()
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "DataSheet" Then
ws.Select
ws.Application.Run "MacroCopy"
End If
Next
End Sub
Sub MacroCopy()
Range("A1:H4630").Select
Selection.Copy
Sheets("Transfers").Paste
End Sub
Thanks Dan, i had to delete this because the strings 'trans' and 'trsf' appear as part of other strings not just as the only content of cells.
'make sure that trans or trsf exists in the check range Set TestTRANS = `CheckRng.Find(What:="trans", LookIn:=xlValues, LookAt:=xlWhole) Set TestTRSF = CheckRng.Find(What:="trsf", LookIn:=xlValues, LookAt:=xlWhole) If TestTRANS Is Nothing And TestTRSF Is Nothing Then MsgBox ("Could not find ""trans"" or ""trsf"" in column B, exiting!") Exit Sub End If`
I also added the second criteria as an array but it'd giving a syntax error . .. the code runs fine with the two initial two criteria , but I want to add trfs and trnsf
With DataRng
.AutoFilter Field:=2, Criteria1:="=*trsf*", Operator:=xlOr, Criteria2:=Array( _trfs, _trnsf), _Operator:=xlFilterValues
End With
I think the code below does everything you're looking for:
Option Explicit
Sub BringItAllTogether()
Dim DataSheet As Worksheet, TransfersSheet As Worksheet
Dim DataRng As Range, CheckRng As Range, _
TestTRANS As Range, TestTRSF As Range, _
CopyRng As Range, PasteRng As Range
'make sure the data sheet exists
If Not DoesSheetExist("DataSheet", ThisWorkbook) Then
MsgBox ("No sheet named ""DataSheet"" found, exiting!")
Exit Sub
End If
'assign the data sheet, data range and check range
Set DataSheet = ThisWorkbook.Worksheets("DataSheet")
Set DataRng = DataSheet.Range("$A$1:$H$4630")
Set CheckRng = DataSheet.Range("$B$1:$B$4630")
'make sure that trans or trsf exists in the check range
Set TestTRANS = CheckRng.Find(What:="trans", LookIn:=xlValues, LookAt:=xlWhole)
Set TestTRSF = CheckRng.Find(What:="trsf", LookIn:=xlValues, LookAt:=xlWhole)
If TestTRANS Is Nothing And TestTRSF Is Nothing Then
MsgBox ("Could not find ""trans"" or ""trsf"" in column B, exiting!")
Exit Sub
End If
'apply autofilter and create copy range
With DataRng
.AutoFilter Field:=2, Criteria1:="=*trsf*", Operator:=xlOr, Criteria2:="=*trans*"
End With
Set CopyRng = DataRng.SpecialCells(xlCellTypeVisible)
DataSheet.AutoFilterMode = False
'make sure a sheet named transfers doesn't already exist, if it does then delete it
If DoesSheetExist("Transfers", ThisWorkbook) Then
MsgBox ("Whoops, ""Transfers"" sheet already exists. Deleting it!")
Set TransfersSheet = Worksheets("Transfers")
TransfersSheet.Delete
End If
'create transfers sheet
Set TransfersSheet = Worksheets.Add
TransfersSheet.Name = "Transfers"
'paste the copied range to the transfers sheet
CopyRng.Copy
TransfersSheet.Range("A1").PasteSpecial Paste:=xlPasteAll
End Sub
Public Function DoesSheetExist(SheetName As String, BookName As Workbook) As Boolean
Dim obj As Object
On Error Resume Next
'if there is an error, sheet doesn't exist
Set obj = BookName.Worksheets(SheetName)
If Err = 0 Then
DoesSheetExist = True
Else
DoesSheetExist = False
End If
On Error GoTo 0
End Function

Generate sheet with predetermined table header

I have sheet named "raw" and I want to filter it using button function. in "raw" sheet, there this table which have random header. what I want to do is that when I click the button, then new sheet "filter" will be generate with table where the header is more organized.
I am able to create new sheet within button but generating organized table is harder. I want to ask is it possible to create this table? I am a VBA Learner and interest in learn more in VBA programming.
By the way, I have try to make table using
Dim Ws As Worksheet
Set Ws = ThisWorkbook.Sheets("Sheet_Name")
Ws.ListObjects.Add(xlSrcRange, Ws.Range("A$xx:$V$xx"), , xlYes).Name = "New_Table_Name"
Ws.ListObjects("New_Table_Name").TableStyle = "TableStyleLight1"
and still I cannot naming the column table header.
Create a new Standard VBA module and paste the code bellow
If Worksheets("Filter") already exists:
Option Explicit
Public Sub CopyTable() 'Worksheets("Filter") exists
Const TBL_ID = "New_Table_Name"
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Raw")
Set ws2 = ThisWorkbook.Worksheets("Filter")
Application.ScreenUpdating = False
ws1.ListObjects(1).Range.Copy
With ws2
.Cells(1).PasteSpecial Paste:=xlPasteAll
.Cells(1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1).Select
.ListObjects(1).Name = TBL_ID
MoveTableCols ws2, TBL_ID 'calls 3rd Sub **************
End With
Application.ScreenUpdating = True
End Sub
This will create a new Worksheet called "Filter"
Public Sub CopyWs() 'Creates a new Worksheets("Filter")
Const TBL_ID = "New_Table_Name"
Dim ws1 As Worksheet, ws2 As Worksheet, wsCount As Long
Application.ScreenUpdating = False
With ThisWorkbook
Set ws1 = .Worksheets("Raw")
ws1.Copy After:=.Worksheets(.Worksheets.Count)
wsCount = .Worksheets.Count
Set ws2 = .Worksheets(wsCount)
End With
ws2.Name = "Filter"
ws2.ListObjects(1).Name = TBL_ID
MoveTableCols ws2, TBL_ID 'calls 3rd Sub **************
Application.ScreenUpdating = True
End Sub
The Sub bellow is called by both Subs above, and reorganizes the new table
'Called by CopyTable() and CopyWs() Subs
Private Sub MoveTableCols(ByRef ws As Worksheet, ByVal tblId As String)
Dim arr As Variant
With ws
.Rows(4).Delete Shift:=xlUp 'To delete rows based on criteria use Autofilter
.ListObjects(tblId).ListColumns.Add Position:=6
arr = .ListObjects(tblId).ListColumns(1).DataBodyRange
.ListObjects(tblId).ListColumns(6).DataBodyRange = arr
arr = .Cells(1)
.Columns(1).Delete Shift:=xlToLeft
.Cells(5) = arr
End With
End Sub
As Vityata mentioned, the Macro Recorder will generate the code for all your manual actions, you'll just need to improve it be removing all Activate and Select statements
Note: A table cannot have 2 identical headers so moving a column involves creating a new column, copying the data from the initial column, then "remembering" the header name, deleting the initial column, and renaming the header for the new column to the initial header name
As far as you are studying VBA for 3 days, it is a really good idea to start using the Macro recorder for tasks like this, at least to have a starting point. This is a simple example from the Macro Recorder:
Sub Makro1()
'
' Makro1 Makro
'
'
Cells.Clear
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$E$13"), , xlNo).Name = _
"Table1"
Range("Table1[#All]").Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight9"
Range("Table1[[#Headers],[Column1]]").Select
ActiveCell.FormulaR1C1 = "Header1"
Range("Table1[[#Headers],[Column2]]").Select
ActiveCell.FormulaR1C1 = "Second Header"
Range("Table1[[#Headers],[Column3]]").Select
ActiveCell.FormulaR1C1 = "Third Header"
Range("Table1[[#Headers],[Column4]]").Select
ActiveCell.FormulaR1C1 = "Forth Header"
Range("Table1[[#Headers],[Column5]]").Select
ActiveCell.FormulaR1C1 = "Fifth Header"
Range("A2").Select
End Sub
Play a bit, see how it works, use F8. After some time, you can look for a way to avoid the .Select and ActiveSheet. This is some example that can be automized further with a loop, based on the number of the header rows. However, it does not use ActiveSheet and Select:
Option Explicit
Sub TestMe()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
Dim tbl As ListObject
With ws
.Cells.Clear
.ListObjects.Add(xlSrcRange, .Range("A1:E10"), , xlNo).Name = "MyFirstTable"
Set tbl = .ListObjects(1)
tbl.HeaderRowRange.Cells(1, 1) = "SomeHeader1"
tbl.HeaderRowRange.Cells(1, 2) = "SomeHeader2"
tbl.HeaderRowRange.Cells(1, 3) = "SomeHeader3"
tbl.HeaderRowRange.Cells(1, 4) = "SomeHeader4"
tbl.HeaderRowRange.Cells(1, 5) = "SomeHeader5"
End With
End Sub
E.g., if you want to loop through the header and hive some values, then this is the content of the With ws:
With ws
.Cells.Clear
.ListObjects.Add(xlSrcRange, .Range("A1:E10"), , xlNo).Name = "MyFirstTable"
Set tbl = .ListObjects(1)
Dim myCell As Range
For Each myCell In tbl.HeaderRowRange.Cells
myCell = "SomeHeader " & myCell.Column
Next myCell
End With

Create a AllowEditRange conditional to a value on a column range

I have the code below which allow me to unprotect a sheet with an AllowEditRange, verify which rows of a range in column C has data on it and write the work "Ok" on column B in the rows where data was found in column C. The code also protects the sheet in the end returning to normal with my AllowEditRange but I need that the rows where the "Ok" was stamped are taken out of the AllowEditRange, blocking them for further edition. In other words I'm looking for a way to cancel these rows from the AllowEditRange or delete the range and create a new one excluding the rows with "Ok" in column B.
I'm trying to incorporate something like:
Dim aer As AllowEditRange
For Each aer In ActiveSheet.Protection.AllowEditRanges
aer.Delete
If InStr(-1, cell.Value, "") <> 0 Then
Set aer = workbook.Protection.AllowEditRanges.Add("Edition", workbook.Range("A1:D4"))
aer.Users.Add "Power Users", True
End If
But it's not working no matter what I do. Any help?
Sub Test()
ActiveSheet.Unprotect Password:="Maze"
Dim mainworkBook As Workbook
Set mainworkBook = ActiveWorkbook
Application.ScreenUpdating = False
Dim lastRow As Long
Dim cell As Range
lastRow = Range("C" & Rows.Count).End(xlUp).Row
For Each cell In Range("C32:C70" & lastRow)
If InStr(1, cell.Value, "") <> 0 Then
cell.Offset(, -1).Value = "Ok"
End If
Next
Application.ScreenUpdating = True
ActiveSheet.Protect Password:="Maze"
End Sub
As it was giving me a huge headache and consuming loads of time, I gave up of the AllowEditRanges and came up with a a work around. I just split the code in two and used the good old lock and unlock cells. I'm leaving the code below if anybody got decides to go for it too. Also, the code I came up with is very slow and after a couple of hours I decided to ask if anybody has a faster alternative.
Sub LockRow()
Dim rChk As Range, r1st As Range
Set r1st = Columns("B").Find(What:="Ok", _
after:=Cells(Rows.Count, "B"), _
LookIn:=xlValues, lookat:=xlPart, _
searchdirection:=xlNext)
If Not r1st Is Nothing Then
Set rChk = r1st
Do
ActiveSheet.Unprotect Password:="Maze"
rChk.EntireRow.Locked = True
ActiveSheet.Protect Password:="Maze"
Set rChk = Columns("B").FindNext(after:=rChk)
Loop While rChk.Address <> r1st.Address
End If
Set r1st = Nothing
Set rChk = Nothing
End Sub

VBA single col select & copy (from last cell to last cell with data) gives “Method 'range' of object _Global… ”

The purpose of my code is to:
Clean the two destination column
At source worksheet jump to last cell(1048576) in a specific column
from bottom, jump to the last cell with data, and select from there
to the top cell
copy, paste, and remove duplicates (the removeduplicates is a working
part)
I have to select the range from bottom because of embedded empty cells that prevents excel to select further cells with data.
The line that performs selection seems correct after multiple checks, and also tried to
use string form ("AC") for parameter
number form (13)
put the cell number in a Range()
Despite all my efforts the line gives an "Run-time error '1004' : Method 'Range' of object'_Global' failed" error.
I removed even all other params except for the, single cell reference, tried to rearrange my code and solve by some other way.
The code part
Sheets("Data").Cells(Rows.Count, "AC").End(xlUp).Row
returns the value(row number) of the first cell with data from bottom. That would be the end of the selection.
I know that there are some parts that doesn't match the description, but they are also irrelevant in terms of the error. (for example at line 17-18, it selects the entire column, but I can fix that later.)
Here is my code, I put a comment next to the problematic part.
Sub CopyUniqueProcList()
Dim ContainWord As String
Dim SrcSheet As Worksheet
Dim DestSheet As Worksheet
Dim TypeRng As Range
Dim TypeRngDest As Range
Dim GrundRng As Range
Dim GrundRngDest As Range
Dim TRD_E As Integer
Dim GRD_E As Integer
Set SrcSheet = Worksheets("Data")
Set DestSheet = Worksheets("lTopTenHelper")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set TypeRng = SrcSheet.Range("AC4")
Set TypeRngDest = DestSheet.Range("A1")
Set TRD_E = DestSheet.Cells(Rows.Count, "A")
Set GrundRng = SrcSheet.Range("AE4")
Set GrundRngDest = DestSheet.Range("D1")
Set GRD_E = DestSheet.Cells(Rows.Count, "D")
TRD_E = DestSheet.Cells(DestSheet.Rows.Count, "A").End(xlUp).Row
GRD_E = DestSheet.Cells(DestSheet.Rows.Count, "D").End(xlUp).Row
Sheets("lTopTenHelper").Range(TypeRngDest, "A" & TRD_E).Clear
Sheets("lTopTenHelper").Range(GrundRngDest, "D" & GRD_E).Clear
If TypeRng.Value <> 0 Then
Range(TypeRng, "AC" & Sheets("Data").Cells(Rows.Count, "AC").End(xlUp).Row).Copy 'Error thrown here
Sheets("lTopTenHelper").Cells(Rows.Count, "A").End(xlUp).Offset(0).PasteSpecial Paste:=xlPasteValues
End If
Sheets("lTopTenHelper").Range(TypeRngDest, "AC" & Sheets("Data").Cells(Rows.Count, "AC").End(xlUp).Row).RemoveDuplicates Columns:=Array(1), Header:=xlNo
If GrundRng.Value <> 0 Then
Range(GrundRng, "AE" & Sheets("Data").Cells(Rows.Count, "AE").End(xlUp).Row).Copy
Sheets("lTopTenHelper").Cells(Rows.Count, "D").End(xlUp).Offset(0).PasteSpecial Paste:=xlPasteValues
End If '6?
Sheets("lTopTenHelper").Range(GrundRngDest, "AE" & Sheets("Data").Cells(Rows.Count, "AE").End(xlUp).Row).RemoveDuplicates Columns:=Array(1), Header:=xlNo
Application.Calculation = xlCalculationAutomatic
Exit Sub
End Sub
Any help/suggestion/other solution of task is welcome.
Thanks in advance.
The code below will get you started,
Option Explicit
Sub CopyUniqueProcList()
Dim ContainWord As String
Dim SrcSheet As Worksheet
Dim DestSheet As Worksheet
Dim TypeRng As Range
Dim TypeRngDest As Range
Dim GrundRng As Range
Dim GrundRngDest As Range
Dim TRD_E As Long
Dim GRD_E As Long
Set SrcSheet = Worksheets("Data")
Set DestSheet = Worksheets("lTopTenHelper")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set TypeRng = SrcSheet.Range("AC4")
Set GrundRng = SrcSheet.Range("AE4")
With DestSheet
' find last row with data in Column A
TRD_E = .Cells(.Rows.Count, "A").End(xlUp).Row
GRD_E = .Cells(.Rows.Count, "D").End(xlUp).Row
Set TypeRngDest = .Range("A1:A" & TRD_E)
Set GrundRngDest = .Range("D1:D" & GRD_E)
TypeRngDest.Clear
GrundRngDest.Clear
End With
If TypeRng.Value <> 0 Then
SrcSheet.Range("AC4:AC" & SrcSheet.Cells(SrcSheet.Rows.Count, "AC").End(xlUp).Row).Copy
DestSheet.Cells(TRD_E, "A").Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If
' you can take it from here ... ?
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End Sub

Resources