VLOOKUP Macro for AutoFiltered data - excel

I'm still learning VBA and am wondering if there's a way to run a VLOOKUP in a filtered range.
For example, in the code below, after I filter the data, the first row with data is A4.
However, I have to manually specify that the first row of data is in A4.
My question is whether it's possible so the macro detects the first row of data itself instead of me having to specify.
I've read about potentially using SpecialCells.
I am trying to do this as the datasets I receive change daily, so the first filtered row being A4 today might be A15 or whatever tomorrow.
Thanks
Range("A4").Select '/have to specify range here
Dim formul As String
formul = "=VLOOKUP(C2,Sheet2!A:B,2,0)"
Range("A4:A" & Cells(Rows.Count, 1).End(xlUp).Row) = [formul] '/also specify range here
'''
edit: code with SpecialCells:
''' vba
Range("A1").Select '/have to specify range here
Dim formul As String
formul = "=VLOOKUP(C1,Sheet2!A:B,2,0)"
Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible) = [formul] '/also specify range here
'''

Formula To Filtered Cells
This will filter column C and write formulas to the filtered cells in column A.
Option Explicit
Sub FormulaToFilteredCells()
Const sName As String = "Sheet2"
Const dName As String = "Sheet1"
Const dLookupColumn As Long = 1
Const dCriteriaColumn As Long = 3
Const dCriteria As String = "Yes"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
If dws.FilterMode Then dws.ShowAllData ' remove previous filter
Dim drg As Range ' Destination Table Range (has headers)
Set drg = dws.Range("A1").CurrentRegion.Columns(dCriteriaColumn)
Dim ddrg As Range ' Destination Data Range (no headers)
Set ddrg = drg.Resize(drg.Rows.Count - 1).Offset(1)
Dim dcOffset As Long: dcOffset = dLookupColumn - dCriteriaColumn
drg.AutoFilter 1, dCriteria
Dim dvdrg As Range ' Destination Visible Data Range
On Error Resume Next
Set dvdrg = ddrg.SpecialCells(xlCellTypeVisible).Offset(, dcOffset)
On Error GoTo 0
dws.AutoFilterMode = False
If dvdrg Is Nothing Then Exit Sub ' no filtered cells
dvdrg.Formula = "=VLOOKUP(" & dvdrg.Cells(1).Offset(, -dcOffset) _
.Address(0, 0) & ",'" & dName & "'!A:B,2,0)"
End Sub

Working with filtered data is possible with array formulas as shown here, here and here.
Why don't you copy the filtered data to a new Worksheet?
And work with vlookup on the filtered data in the 2nd Worksheet?
Sample Data: Wikipedia => List_of_countries_by_population
Sub FilterTable_and_Copy()
'Prepare Sheet2
If Sheets(2).Name <> "Filtered Data" Then
Sheets.Add After:=Sheets(1)
Sheets(2).Name = "Filtered Data"
End If
Sheets(2).Columns("A:G").ClearContents
'The Data is prepared in the Table "myTable"
'ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$F$100"), , _
' xlYes).Name = "myTable"
'Filter Data
Sheets(1).Select
ActiveSheet.Range("myTable").AutoFilter Field:=2, Criteria1:="Asia"
'Copy Filtered Data to Sheet2
Range("myTable").Copy
Sheets(2).Select
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Copy Header
Sheets(1).Select
Rows("1:1").Copy
Sheets(2).Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Format Columns Width
Columns("A:F").ColumnWidth = 30
Columns("A:F").EntireColumn.AutoFit
Range("G1").Select
'Create Table "Table_FilteredData"
Sheets(2).ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , _
xlYes).Name = "Table_FilteredData"
'Correct Formatting Issue
Dim myRange As Range
With Sheets(2).ListObjects("Table_FilteredData")
Set myRange = .Range
.Unlist
End With
With myRange
.Interior.ColorIndex = xlColorIndexNone
.Font.ColorIndex = xlColorIndexAutomatic
.Borders.LineStyle = xlLineStyleNone
End With
Sheets(2).ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , _
xlYes).Name = "Table_FilteredData"
Sheets(2).ListObjects(1).TableStyle = "TableStyleMedium3"
End Sub
Data filtered for "region = Asia":

Related

Receiving Error when trying to run macro on multiple sheets using VBA

I have the below macro that should be running on each sheet in my workbook. When I run this code, I am getting the following error: 'A table cannot overlap another table' and it is highlighting this line:
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$I"), , xlYes).Name = _
"Table1"
Is this because I applied the macro to table one and now it cannot be applied to the other tables?
All sheets have the same column headers but different number of rows (not sure if that matters). Essentially all I am trying to do is get rid of the index, format the data into a table, extend the column lengths to fit all the column names, and rename the columns.
Another thing to note, there are about 170 sheets that this macro needs to run through.
Sub forEachWs()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call CreateTables(ws)
Next
End Sub
Sub CreateTables(ws As Worksheet)
'
' CreateTables Macro
'
' Keyboard Shortcut: Ctrl+Shift+S
'
With ws
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("A:I").Select
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$I"), , xlYes).Name = _
"Table1"
Columns("A:I").Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight1"
Columns("A:I").EntireColumn.AutoFit
Range("Table1[[#Headers],[Tier2_ID]]").Select
ActiveCell.FormulaR1C1 = "Community ID"
Range("Table1[[#Headers],[Tier2_Name]]").Select
ActiveCell.FormulaR1C1 = "Community Name"
Range("Table1[[#Headers],[Current_MBI]]").Select
ActiveCell.FormulaR1C1 = "Current MBI"
Range("Table1[[#Headers],[countMBI]]").Select
ActiveCell.FormulaR1C1 = "Cout"
Range("Table1[[#Headers],[Cout]]").Select
ActiveCell.FormulaR1C1 = "Count"
Range("Table1[[#Headers],[TotalEDVisits]]").Select
ActiveCell.FormulaR1C1 = "Total ED Visits"
Range("Table1[[#Headers],[EDtoIPTotal]]").Select
ActiveCell.FormulaR1C1 = "Total ED to Inpatient"
Range("Table1[[#Headers],[totalSev1to3]]").Select
ActiveCell.FormulaR1C1 = "Severity 1 to 3"
Range("Table1[[#Headers],[totalSev4to6]]").Select
ActiveCell.FormulaR1C1 = "Severity 4 to 6"
Range("Table1[[#Headers],[totalPaid]]").Select
ActiveCell.FormulaR1C1 = "Total Paid"
Range("L22").Select
End With
End Sub
Convert Ranges to Tables
The table names in a workbook have to be unique.
This code (re)names each table sequentially i.e. Table1, Table2, Table3....
This is a one-time operation code, so test it first on a copy of your workbook.
If (when) you're satisfied with the outcome, run it in your original workbook.
Now the code is no longer needed (useless).
If you really need to select the cell L22 on each worksheet, you have to make sure the workbook is active (in the first code use If Not wb Is ActiveWorkbook Then wb.Activate).
In the second code, you can then use Application.Goto ws.Range("L22") right before (above) the last 'Else.
Sub ConvertToTables()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet
Dim n As Long
For Each ws In wb.Worksheets
n = n + 1 ' to create Table1, Table2, Table3...
ConvertToTable ws, "Table", n
Next
End Sub
Sub ConvertToTable( _
ByVal ws As Worksheet, _
ByVal TableBaseName As String, _
ByVal TableIndex As Long)
'
' CreateTables Macro
'
' Keyboard Shortcut: Ctrl+Shift+S
'
' Note that all column names have to be unique i.e. you cannot
' rename the 'countMBI' column to 'Cout' before the existing 'Cout' column
' has been renamed.
Const OldColsList As String _
= "Tier2_ID,Tier2_Name,Current_MBI,Cout," _
& "countMBI,TotalEDVisits,EDtoIPTotal,totalSev1to3," _
& "totalSev4to6,totalPaid"
Const NewColsList As String _
= "Community ID,Community Name,Current MBI,Count," _
& "Cout,Total ED Visits,Total ED to Inpatient,Severity 1 to 3," _
& "Severity 4 to 6,Total Paid"
Const FirstCellAddress As String = "A1"
' Reference the first cell ('fCell').
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
' Check if the first cell is part of a table ('tbl').
' A weak check whether the table has already been created.
Dim tbl As ListObject: Set tbl = fCell.ListObject
If tbl Is Nothing Then ' the first cell is not part of a table
' Reference the range ('rg').
Dim rg As Range: Set rg = fCell.CurrentRegion
' Delete the first column. Note that the range has shrinked by a column.
rg.Columns(1).Delete xlShiftToLeft
' Convert the range to a table ('tbl').
Set tbl = ws.ListObjects.Add(xlSrcRange, rg, , xlYes)
With tbl
.Name = TableBaseName & CStr(TableIndex)
.TableStyle = "TableStyleLight1"
' Write the lists to string arrays ('OldCols', 'NewCols')
Dim OldCols() As String: OldCols = Split(OldColsList, ",")
Dim NewCols() As String: NewCols = Split(NewColsList, ",")
Dim lc As ListColumn
Dim n As Long
' Loop through the elements of the arrays...
For n = 0 To UBound(OldCols)
' Attempt to reference a table column by its old name.
On Error Resume Next
Set lc = .ListColumns(OldCols(n))
On Error GoTo 0
' Check if the column reference has been created.
If Not lc Is Nothing Then ' the column exists
lc.Name = NewCols(n) ' rename the column
Set lc = Nothing ' reset to reuse in the next iteration
'Else ' the column doesn't exist; do nothing
End If
Next n
' The columns should be autofitted after their renaming.
.Range.EntireColumn.AutoFit
End With
'Else ' the first cell is part of a table; do nothing
End If
End Sub

Auto Filter Array only Filtering by Last Criteria in Array

I am trying to sort a table by deleting rows that have their cell in column 9 NOT beginning with S, X, or P. Below is the code that I have that filters for the rows that do not meet my criteria, and then deletes them, and then shows the remaining values.
Range("I:I").NumberFormat = "#"
lo.Range.AutoFilter Field:=9, Criteria1:=Array("<>S*", "<>X*", "<>P*"), Operator:=xlOr
Application.DisplayAlerts = False
lo.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
lo.AutoFilter.ShowAllData
Currently, regardless or order, only rows that contain the last criteria in the array are kept.
Delete Multi-Criteria Rows of an Excel Table
You cannot have more than two criteria (elements) with wild characters.
As a workaround, this solution adds a new column and writes a formula to it. The formula returns a boolean indicating whether a string starts with the chars from the list. Then it filters the new column by False and deletes these filtered tables' (not worksheet's) rows. Finally, it deletes the new column.
The data to the right (one empty column is assumed) stays intact, it is not shifted in any way hence the inserting and deleting of a worksheet column instead of using .ListColumns.Add.
Adjust the values in the constants section.
Option Explicit
Sub DeleteMultiCriteriaRows()
Const wsName As String = "Sheet1"
Const tblName As String = "Table1"
Const NotFirstCharList As String = "s,x,p"
Const CritCol As Long = 9
' Extract chars for the formula.
Dim Nfc() As String: Nfc = Split(NotFirstCharList, ",")
Dim NotFirstChar As String: NotFirstChar = "{"
Dim n As Long
For n = 0 To UBound(Nfc)
NotFirstChar = NotFirstChar & """" & Nfc(n) & ""","
Next n
NotFirstChar = Left(NotFirstChar, Len(NotFirstChar) - 1) & "}"
Erase Nfc
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim tbl As ListObject: Set tbl = ws.ListObjects(tblName)
Application.ScreenUpdating = False
With tbl
If Not .ShowAutoFilter Then .ShowAutoFilter = True
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData ' remove filter
.ListColumns(CritCol).DataBodyRange.NumberFormat = "#" ' ?
Dim nFormula As String
nFormula = "=ISNUMBER(MATCH(LEFT(" & .Name & "[#" _
& .ListColumns(CritCol).Name & "],1)," & NotFirstChar & ",0))"
Dim LastCol As Long: LastCol = .ListColumns.Count
With .ListColumns(1) ' write formulas to newly inserted column
.Range.Offset(, LastCol).EntireColumn.Insert
.DataBodyRange.Offset(, LastCol).Formula = nFormula
End With
LastCol = LastCol + 1 ' think new column
.Range.AutoFilter LastCol, False ' think Not(FirstChar)
Dim vrg As Range ' Visible Range
On Error Resume Next ' prevent 'No cells found...' error
Set vrg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter.ShowAllData ' remove filter
If Not vrg Is Nothing Then ' delete visible rows
vrg.Delete Shift:=xlShiftUp
End If
.ListColumns(LastCol).Range.EntireColumn.Delete ' delete new column
End With
Application.ScreenUpdating = True
End Sub
This code will delete any rows that have a value in the 9th column of the first table on the first sheet in a workbook that doesn't start with one of the letters in arrBeginsWith.
There are other ways to do achieve what you want, for example adding a helper column that identifies the rows to delete with a formula and then filtering on that column.
Option Explicit
Sub KeepRowsStartingWith()
Dim tbl As ListObject
Dim rngDelete As Range
Dim arrBeginsWith As Variant
Dim arrData As Variant
Dim idxRow As Long
Dim StartRow As Long
Dim Res As Variant
Set tbl = Sheets(1).ListObjects(1)
With tbl.ListColumns(9).DataBodyRange
StartRow = .Cells(1, 1).Row
arrData = .Value
End With
ReDim arrDeleteRows(1 To UBound(arrData, 1))
arrBeginsWith = Array("S", "X", "P")
For idxRow = 1 To UBound(arrData, 1)
Res = Application.Match(Left(arrData(idxRow, 1), 1), arrBeginsWith, 0)
If IsError(Res) Then
If rngDelete Is Nothing Then
Set rngDelete = Intersect(tbl.DataBodyRange, Sheets(1).Rows(idxRow + StartRow - 1))
Else
Set rngDelete = Union(rngDelete, Intersect(tbl.DataBodyRange, Sheets(1).Rows(idxRow + StartRow - 1)))
End If
End If
Next idxRow
rngDelete.Delete xlShiftUp
End Sub
I ended up creating a new column in my table with an if statement to identify if a cell began with a letter or number. Then I filtered for the rows that had a number, deleted those rows, and then showed the remaining rows. I then deleted the helper column as to not have to deal with it later.
ThisWorkbook.Worksheets("Aluminum Futures").Columns("T:T").Select
Selection.Insert Shift:=xlToRight
Range("T1") = "Letter/Number"
Range("T2").Select
ActiveCell.FormulaR1C1 = "=IF(ISERR(LEFT(RC[-11],1)*1),""letter"",""number"")"
Range("T2").Select
Selection.AutoFill Destination:=Range("PF[Letter/Number]")
Range("PF[Letter/Number]").Select
lo.Range.AutoFilter Field:=20, Criteria1:="number"
Application.DisplayAlerts = False
lo.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
lo.AutoFilter.ShowAllData
Columns("T:T").Delete

Copy and Paste the Unique Values from Filtered Column

I'm trying to get the Unique values from the Filtered Range and trying to paste the same into specific worksheet. But I'm facing a Run-Time Error 1004 (Database or Table Range is not Valid).
Set DataSet = MainSht.Range(Cells(1, 1), Cells(Lrows, Lcols))
With DataSet
.AutoFilter field:=3, Criteria1:=Array("Corporate Treasury - US", "F&A"), Operator:=xlFilterValues
Set DataRng = .Offset(1, 10).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
.AutoFilter
With DataRng
.AdvancedFilter Action:=xlFilterCopy, copytorange:=Wb.Sheets("Corporate Treasury - US").Range("A2"), Unique:=True 'Getting Error Here
End With
End With
Appreciate your help in advance!!
Copy Filtered Unique Data
Basically
'Remove' previous filters.
Create accurate range references before applying AutoFilter.
The filter is applied on the Table Range (headers included).
Use error handling with SpecialCells (think no cells found).
Apply SpecialCells to the Data Range (no headers).
It is usually safe to 'remove' the filter after the reference to the SpecialCells range is created.
Copy/paste and only then apply RemoveDuplicates (xlNo when Data Range).
Optionally, apply Sort (xlNo when Data Range) to the not necessarily exact destination range (ducdrg i.e. no empty cells (due to RemoveDuplicates)).
(xlYes when Table Range.)
A Study
Adjust the values in the constants section (the worksheets are off).
Option Explicit
Sub CopyFilteredUniqueData()
' Source
Const sName As String = "Sheet1"
' Copy
Const sCol As Variant = "K" ' or 11
' Filter
Const sfField As Long = 3
Dim sfCriteria1 As Variant
sfCriteria1 = Array("Corporate Treasury - US", "F&A")
Dim sfOperator As XlAutoFilterOperator: sfOperator = xlFilterValues
' Destination
Const dName As String = "Sheet2"
' Paste
Const dFirst As String = "A2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Debug.Print vbLf & "Source (""" & sws.Name & """)"
' Remove possble previous filters.
If sws.AutoFilterMode Then
sws.AutoFilterMode = False
End If
' Source Table Range
Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
Debug.Print strg.Address(0, 0)
' Source Column Data Range (No Headers)
Dim scdrg As Range
With strg.Columns(sCol)
Set scdrg = .Resize(.Rows.Count - 1).Offset(1)
End With
Debug.Print scdrg.Address(0, 0) & " (No Headers)"
' Filter.
strg.AutoFilter sfField, sfCriteria1, sfOperator
' Source Filtered Column Data Range (No Headers)
On Error Resume Next
Dim sfcdrg As Range: Set sfcdrg = scdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
sws.AutoFilterMode = False ' no need for the filter anymore
If sfcdrg Is Nothing Then Exit Sub ' no matching cells
Debug.Print sfcdrg.Address(0, 0) & " (No Headers)"
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Debug.Print vbLf & "Destination (""" & dws.Name & """)"
' Destination First Cell
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
' Destination Column Data Range (No Headers)
Dim dcdrg As Range: Set dcdrg = dfCell.Resize(sfcdrg.Cells.Count)
Debug.Print dcdrg.Address(0, 0) & " (No Headers)"
' Copy.
sfcdrg.Copy dcdrg
' Remove duplicates.
dcdrg.RemoveDuplicates 1, xlNo
Debug.Print dcdrg.Address(0, 0) & " (No Headers, Empty Cells Included)"
' Destination Last Cell
Dim dlCell As Range
Set dlCell = dcdrg.Find("*", , xlFormulas, , , xlPrevious)
' Destination Unique Column Data Range (No Headers)
Dim ducdrg As Range
With dcdrg
Set ducdrg = .Resize(dlCell.Row - .Row + 1)
End With
Debug.Print ducdrg.Address(0, 0) & " (No Headers, Empty Cells Excluded)"
' Sort ascending.
ducdrg.Sort ducdrg, , Header:=xlNo
End Sub
I believe the error is because it cannot past a range of non-contiguous cells within a column.
I got round this by simply using the .copy command, but this will paste your unique list with the underlying formatting. See my solution below -
> Set DataSet = MainSht.Range(Cells(1, 1), Cells(Lrows, Lcols))
>
> With DataSet
> .AutoFilter field:=3, Criteria1:=Array("Corporate Treasury - US", "F&A"), Operator:=xlFilterValues
> Set DataRng = .Offset(1, 10).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
> DataRng.Copy Destination:=Wb.Sheets("Corporate Treasury - US").Range("A2:A" & (DataRng.Rows.Count + 2))
>
> End With
If you do not want to bring across cell properties/formatting from the original worksheet, you could combine the .copy command with a .pastespecial to only paste in values, formulas or whatever details you need.

Copy rows in Excel if cell contains name from an array

I have an Excel sheet that contains entries for ~150 employees. Each row contains the name as well as hours worked, pay, team, etc etc etc etc. The B column in each row contains the employees name in Last,First format. About half the employees on the sheet are part time employees. What i'm trying to do is write a macro in VB that copies the entire row if the name in the B column matches one of the names of the part time employees so that one of my coworkers can simply run the macro and paste all of the rows of copied users into a new sheet each week. Here's what I currently have. (I have all of the employees names in the array however I have censored them out) I really don't understand much of the last 50% of the code. This stuff was stuff I found online and have been messing around with.
`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
nameArray = Array(NAMES CENSORED)
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("C" & I & ":F" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub`
This code should work for what you are looking for. It is important to note that the string names in your array must be identical to that in Column B (with the exception of leading and trailing spaces), so if the names are written "LastName, FirstName" then your input data must be identical. This code could be tweaked to not have this requirement, but for now I've left it as such. Let me know if you'd prefer the code be adjusted.
Option Explicit
Sub PartTimeEmployees()
Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")
'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2
'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
For Counter = 1 To UBound(NameArray)
'Performing string operations on the text will be faster than the find method
'It is also essential that the names are entered identically in your array
If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
CurrentSheet.Rows(Count).Copy
NewSheet.Select
NewSheet.Cells(NextRow, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
NextRow = NextRow + 1
Exit For
End If
Next Counter
End If
Next Count
End Sub
No need to loop through the array if you use a Range.AutoFilter Method with the array as criteria.
See comment for each line of operational code.
Option Explicit
Sub partTimers()
Dim nameArray As Variant
'construct an array of the part-time employees' names
nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
"Sfgd, Pxduj", "Lsds, Qwrml", _
"Eqrd, Oqtts")
With Worksheets("Sheet1") 'you should know what worksheet the names are on
'turn off AutoFilter is there is one already in operation
If .AutoFilterMode Then .AutoFilterMode = False
'use the 'island' of cells radiating out from A1
With .Cells(1, 1).CurrentRegion
'apply AutoFilter using array of names as criteria
.AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
'check if there is anything to copy
If Application.Subtotal(103, .Columns(2)) > 1 Then
'copy the filtered range
.Cells.Copy
'create a new worksheet
With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
'paste the filtered range, column widths and cell formats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End If
End With
'turn off the AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
'turn off active copy range
Application.CutCopyMode = False
End With
End Sub

If Condition to create sheets only when Auto filter has data

I have written a code which does the below steps.
1) Loops through a list of products
2) Auto filters the data with each product.
3) Copies and pastes data on to separate worksheets and names it with that product name.
4) Inserts a line at every change in schedule
The only thing I couldn't do it here is to limit separate worksheet creation only for the products available in the source data when auto filtered.
I tried to do this by adding an if condition to add worksheets by product name only if auto filter shows any data but for some reason it is not working.
I would appreciate any help in fixing this problem and clean my code to make it look better and work faster.
Sub runreport()
Dim rRange As Range
Dim Rng As Range
' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename
'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
Sheets("Sheet1").Select
Sheets("Sheet1").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
'This will paste the filtered data from Source Data to the new sheet that is added
Range("a2").Select
ActiveSheet.Paste
ns = ActiveSheet.Name
'Copeis the headers to all the new sheets
Sheets("Sheet1").Select
Range("A1:BC1").Select
Selection.Copy
Sheets(ns).Activate
Range("a1").Select
ActiveSheet.Paste
Columns.AutoFit
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
Next producttype
End Sub
Try this...
Sub runreport()
Dim rRange As Range
Dim Rng As Range
Dim FiltRows As Integer
' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename
'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
With Workbooks("Source.xlsx").Sheets("Sheet1")
FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
End With
If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
Sheets("Sheet1").Select
Sheets("Sheet1").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
'This will paste the filtered data from Source Data to the new sheet that is added
Range("a2").Select
ActiveSheet.Paste
ns = ActiveSheet.Name
'Copeis the headers to all the new sheets
Sheets("Sheet1").Select
Range("A1:BC1").Select
Selection.Copy
Sheets(ns).Activate
Range("a1").Select
ActiveSheet.Paste
Columns.AutoFit
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
End If
Next producttype
End Sub
I would recommend you define more variables than you have it keeps the code cleaner and easier to read as well as eliminates easy errors.
I also recommend always to utilize "option explicit" at the top of every code. It forces defining all variables (when you don't define a variable the program will do it for you (assuming you haven't used option explicit), but excel doesn't always get it correct. Also option explicit helps you avoid typos in variables.
Also as a general rule you rarely if ever have to .select anything to do what you need to with vba.
Below is an example of a cleaned up and shortened code which utilized variable definition and instantiation.
Sub runreport()
Dim wb As Workbook
Dim wsSched As Worksheet
Dim wsNew As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rRange As Range
Dim producttype As Range
Dim Filename As String
Dim FiltRows As Integer
Dim myRow As Integer
'instantiate Variables
Set wb = ThisWorkbook
Set wsSched = wb.Worksheets("Schedule")
' Open the Source File
Filename = Application.GetOpenFilename()
Set wbSource = Workbooks.Open(Filename)
Set wsSource = wbSource.Worksheets("Sheet1")
'Loops through each product type range from the macro spreadsheet.
For Each producttype In wsSched.Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
With wsSource
.AutoFilterMode = False
.Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
'Add new workbook
Set wsNew = wb.Sheets.Add(After:=ActiveWorkbook.Sheets(Sheets.Count))
'Copy filtered data including header
.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
'Paste filterd data and header
wsNew.Range("A1").PasteSpecial
Application.CutCopyMode = False
wsNew.Columns.AutoFit
'Rename new worksheet
wsNew.Name = WorksheetFunction.VLookup(producttype, wb.Worksheets("Sheet2").Range("A:B"), 2, False)
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
End If
End With
Next producttype
End Sub
First, you can check this answer for ways to optimize your vba code
As for your code in its current form, it would be easiest if you select the entire range of your product code data first. Then you can check this range after your filter and determine if all the rows are hidden. See a sample of the code below
Dim productData as Range
Set productData = Range(Range("A2"), Range("A2").End(xlDown).End(xlToRight))
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter _
Field:=4, Criteria1:=producttype
' The error check will skip the creation of a new sheet if the copy failed (i.e. returns a non-zero error number)
On Error Resume Next
' Copies only the visible cells
productData.SpecialCells(xlCellTypeVisible).Copy
If Err.number = 0 then
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = Application.VLookup(producttype, _
ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
Range("a2").Select
ActiveSheet.Paste
End If
While you can Range.Offset one row and check if the Range.SpecialCells method with xlCellTypeVisible is Not Nothing, I prefer to use the worksheet's SUBTOTAL function. The SUBTOTAL function discards hidden or filtered rows from its operations so a simple COUNTA (SUBTOTAL subfunction 103) of the cells below the header will tell you if there is anything available.
Sub runreport()
Dim rRange As Range, rHDR As Range, rVAL As Range, wsn As String
Dim fn As String, owb As Workbook, twb As Workbook
Dim i As Long, p As Long, pTYPEs As Variant
pTYPEs = ThisWorkbook.Sheets("Schedule").Range("Product").Value2
Set twb = ThisWorkbook
' Open the Source File
fn = Application.GetOpenFilename()
Set owb = Workbooks.Open(fn)
With owb
'is this Workbooks("Source.xlsx")?
End With
With Workbooks("Source.xlsx").Worksheets("Sheet1")
With .Cells(1, 1).CurrentRegion
'store the header in case it is needed for a new worksheet
Set rHDR = .Rows(1).Cells
'reset the the filtered cells
Set rVAL = Nothing
For p = LBound(pTYPEs) To UBound(pTYPEs)
.AutoFilter Field:=4, Criteria1:=pTYPEs(p)
With .Resize(.Rows.Count - 1, 7).Offset(1, 0) '<~~resize to A:G and move one down off the header row
If CBool(Application.Subtotal(103, .Cells)) Then
'there are visible cells; do stuff here
Set rVAL = .Cells
wsn = Application.VLookup(pTYPEs(p), twb.Worksheets("Sheet2").Range("A:B"), 2, False)
'if the wsn worksheet doesn't exist, go make one and come back
On Error GoTo bm_New_Worksheet
With Worksheets(wsn)
On Error GoTo bm_Safe_Exit
rVAL.Copy Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
'when inserting rows, always work from the bottom to the top
For i = .Cells(Rows.Count, 3).End(xlUp).Row To 3 Step -1
If .Cells(i, 3).Value2 <> .Cells(i - 1, 3).Value2 Then
.Rows(i).Insert
End If
Next i
'autofit the columns
For i = .Columns.Count To 1 Step -1
.Columns(i).AutoFit
Next i
End With
End If
End With
Next p
End With
End With
GoTo bm_Safe_Exit
bm_New_Worksheet:
On Error GoTo 0
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = wsn
rHDR.Copy Destination:=.Cells(1, 1)
End With
Resume
bm_Safe_Exit:
End Sub
When a worksheet that is referenced by the wsn string does not exist, the On Error GoTo bm_New_Worksheet runs off and creates one. The Resume brings the code processing right back to the place it errored out.
One caution when using this method is to ensure that you have unique, legal worksheet names returned by your VLOOKUP function.

Resources