My intention was to have the following code compile data from my "Low CPM 1" worksheet into an array and then filter my active worksheet based on this array. While the macro does seem to affect the filters, none of the values get filtered out. Any help on this matter would be greatly appreciated
Sub Macro1()
Dim CPM1Array(0 To 300) As Variant
For i = 2 To UBound(CPM1Array)
CPM1Array(i) = Sheets("Low CPM 1").Cells(i, 2).Value
Next i
ActiveSheet.Range("$A$1:$H$251").AutoFilter Field:=3, Criteria1:=("<>1 to Ubound(CPM1Array)"), Operator:=xlFilterValues
End Sub
There is no simple way with autofilter to achieve what you want. You cannot use Criteria1:="<>MyArray"
Alternative
We know which values we do not want. We can find out what are the values of the relevant column
Simply store the values of the relevant column in an array and then remove the unnecessary values from it by comparing it with the array which has values we do not want.
Remove blank cells from the array
Pass the final array to the autofilter.
In Action
Let's say our worksheet looks like as shown in the below image. I am taking an example of only 15 rows.
Code
Sub Sample()
Dim ws As Worksheet
Dim MyAr(1 To 5) As String
Dim tmpAr As Variant, ArFinal() As String
Dim LRow As Long
ReDim ArFinal(0 To 0)
Set ws = ActiveSheet
'~~> Creating an array of values which we do not want
For i = 1 To 5
MyAr(i) = i
Next i
With ws
'~~> Last Row of Col C sice you will filter on 3rd column
LRow = .Range("C" & .Rows.Count).End(xlUp).Row
'~~> Storing the values form C in the array
tmpAr = .Range("C2:C" & LRow).Value
'~~> Compare and remove values which we do not want
For i = 1 To LRow - 1
For j = 1 To UBound(MyAr)
If tmpAr(i, 1) = MyAr(j) Then tmpAr(i, 1) = ""
Next j
Next i
'~~> Remove blank cells from the array by copying them to a new array
For i = LBound(tmpAr) To UBound(tmpAr)
If tmpAr(i, 1) <> "" Then
ArFinal(UBound(ArFinal)) = tmpAr(i, 1)
ReDim Preserve ArFinal(0 To UBound(ArFinal) + 1)
End If
Next i
'~~> Filter on values which you want. Change range as applicable
.Range("$A$1:$H$15").AutoFilter Field:=3, Criteria1:=ArFinal, Operator:=xlFilterValues
End With
End Sub
Output
Related
I am trying to write a script that will look in a column A on sheet1 and see if it is missing any values from column J on sheet2, and if it is missing have the value added to the bottom of the column on sheet1. I found some example code (see below), however, when I modify it to work across the two sheets I get an error.
Sub Macro1()
Dim rngA As Range, rngB As Range, MySel As Range, LastRow As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngA = .Range("A1:A" & LastRow)
Set rngB = .Range("B1", .Range("B" & .Rows.Count).End(xlUp))
End With
For Each cell In rngB
If IsError(Application.Match(cell.Value, rngA, 0)) Then
If MySel Is Nothing Then
Set MySel = cell
Else
Set MySel = Union(MySel, cell)
End If
End If
Next cell
If Not MySel Is Nothing Then MySel.Copy Destination:=ws.Range("A" & LastRow + 1)
End Sub
Any help to modify this to function across sheets would be greatly appreciated. Thanks!
You may try the following code modification, you are getting the error due to the variable cell was not declared and ws.Range("B" & .Rows.Count).End(xlUp) is not a valid range, and you should set Range B by referring to another worksheet if you want to do so:
Sub Macro1()
Dim rngA As Range, rngB As Range, MySel As Range
Dim LastRowA As Long, LastRowB As Long
Dim ws As Worksheet
Dim cell As Range
Set ws = ThisWorkbook.Worksheets(1)
With ws
LastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
LastRowB = .Range("B" & .Rows.Count).End(xlUp).Row
Set rngA = .Range("A1:A" & LastRowA)
Set rngB = .Range("B1:B" & LastRowB)
End With
For Each cell In rngB.Cells
If IsError(Application.Match(cell.Value, rngA, 0)) Then
If MySel Is Nothing Then
Set MySel = cell
Else
Set MySel = Union(MySel, cell)
End If
End If
Next cell
If Not MySel Is Nothing Then MySel.Copy Destination:=ws.Range("A" & LastRowA + 1)
End Sub
Before:
After:
Array approach using one-liner for Match()
Instead of looping through a data range you can execute an array Match()
to compare data values with reference values by a one-liner:
data = Application.Match(ref, data, 0)
Methodical hint
Findings return the position within the reference array, whereas all non-findings (i.e. new and therefore unique values) can be identified easily by a corresponding error entry. This is used to re-write the data array exclusively by the wanted uniques. The resulting data are eventually added in the needed size to the existing data.
Note that commonly the Match() function loops asking for single search values (1st parameter) within a reference array (2nd parameter),
e.g. via Application.Match(SingleSearchValue, reference, 0).
Side note: looping through a range by means of VBA can be time consuming for greater data set, so generally I prefer an array approach.
As OP seems to refer to two sheets with different columns A and J (instead of B),
I demonstrate a solution following this requirement.
Option Explicit
Sub AppendNewItems()
'1) get data & reference arrays via function GetDatafield()
Dim data: data = GetDatafield(Sheet1, "A") ' current data
Dim ref: ref = GetDatafield(Sheet2, "J") ' reference values
Dim NewRow As Long
NewRow = UBound(data) + 1 ' get starting row for new entries
'2) look up all of the data in the reference array and write found positions to data (one-liner)
data = Application.Match(ref, data, 0)
'Edit2: check for no or only 1 reference item ' << 2021-07-23/see comment
On Error Resume Next
Debug.Print data(1, 1)
If Err.Number <> 0 Then
Err.Clear
ReDim tmp(1 To 1, 1 To 1)
tmp(1, 1) = data(1)
data = tmp
End If
'3) take only new (=unique) elements
Dim i As Long, ii As Long
For i = 1 To UBound(data) ' loop through matches
If IsError(data(i, 1)) Then ' identify new (=not found) elements by error
ii = ii + 1 ' increment uniques counter
data(ii, 1) = ref(i, 1) ' replace error element with current reference value
End If
Next
'4) add new data to column A (not more than ii elements)
If ii Then
Sheet1.Range("A" & NewRow).Resize(ii, 1) = data
End If
End Sub
Help function GetDatafield()
Function GetDatafield(sht As Worksheet, Col As String)
Dim LastRow As Long
LastRow = sht.Range(Col & sht.Rows.Count).End(xlUp).Row
'return 1-based 2-dim datafield array
GetDatafield = sht.Range(Col & "1:" & Col & LastRow).Value2
'force single value into array ' << Edit 2021-07-22/see comment
If Not IsArray(GetDatafield) Then ' or: If LastRow = 1 Then
ReDim tmp(1 To 1, 1 To 1)
tmp(1, 1) = sht.Range(Col & "1").Value2
GetDatafield = tmp ' pass 2-dim array
End If
End Function
I am currently trying to copy all filtered values from one excel sheet to another. But it doesnt copy all visible/filtered values. Here a screenshot from my table (the other table where I paste my values is empty):
For example: When I filter the column "Ordnernummer" for the value "1/3" it copies only the following values:
This is how it should look like:
Here is the code I have so far:
Sub getCellRangeValues()
'declare Variant array to hold cell range values
Dim myValuesArray() As Variant
'declare Long to hold the last cell with data
Dim LastRow As Long
'declare variables to hold loop counters used to iterate through the individual values in the cell range
Dim rowCounter As Long
Dim columnCounter As Long
With Worksheets("Konfiguration") 'worksheet with the data
'get the last row from column a
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'get values from all filtered rows and assign them to an array
myValuesArray = .Range("C2:I" & LastRow).SpecialCells(xlCellTypeVisible).Value
End With
ActiveWorkbook.Worksheets("GoLabel").Activate
'loop through each value in array (rows)
For rowCounter = LBound(myValuesArray, 1) To UBound(myValuesArray, 1)
'loop through each value in array (columns)
For columnCounter = LBound(myValuesArray, 2) To UBound(myValuesArray, 2)
Call setData(myValuesArray, rowCounter, columnCounter)
Next columnCounter
Next rowCounter
End Sub
Sub setData(myValuesArray() As Variant, rowCounter As Long, columnCounter As Long)
With Worksheets("GoLabel")
.Cells(rowCounter, columnCounter).Select
ActiveCell.Value = myValuesArray(rowCounter, columnCounter)
End With
End Sub
I found a workaround. Instead of saving the values in an array I just simply copy the values and paste them in my new sheet. Here the corresponding code:
'worksheet with the data
With Worksheets("Konfiguration")
'get the desired column range which is declared in the cell
startRange = "C1"
endRange = "I101"
'select values from all filtered rows
.Range(startRange & ":" & endRange).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
End With
'worksheet which I fill with the copied data
ActiveWorkbook.Worksheets("GoLabel").Activate
With Worksheets("GoLabel")
.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
End Sub
I have created a macro file with Forms and Word to Excel.
In this coding fewthings are not working as per my expectation.
Get unique Employee Name from Excel data base.
I want to add unique employee names from excel database and get is saved in a sheet. After that those values to be added to list box. Here i cannot define a range like "A1:A10".. I want to choose the data from A1 to end data.
If for each cell approach will not work, please help in do while approach
I need help in defining the range and code given below
ListEmployeeName.Clear
For Each cell In Worksheets("SunEmployeeDetails").Range("A1").End(xlDown)
ListEmployeeName.AddItem (cell.Value)
Next
ListEmployeeName.Value = Worksheets("SunEmployeeDetails").Range("A1")
End Sub
Find Last Row and then define your range Range("A1:A" & LastRow)
You can also find the last row and loop through the range using a For loop. Also to get unique Employee Name, you can use On Error Resume Next with a Collection as shown below. I have commented the code below so you should not have a problem understanding it. But if you do then simply ask.
Is this what you are trying? (Untested).
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection
Dim itm As Variant
Set ws = Worksheets("SunEmployeeDetails")
With ws
'~~> Find Last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the range and add it to the unique
'~~> collection using "On Error Resume Next"
For i = 1 To lRow
On Error Resume Next
col.Add .Range("A" & i).Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
ListEmployeeName.Clear
'~~> add the itme from collection to the listbox
For Each itm In col
ListEmployeeName.AddItem itm
Next itm
End Sub
Here is my take on it, techniques taken from here:
Methode 1: Using a dictionary
Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Sheet1 'Change accordingly
'Find the last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A1:A" & lr).Value
End With
'Loop through memory and fill dictionary
For x = LBound(arr) To UBound(arr)
dict(arr(x, 1)) = 1
Next x
'Add array to Listbox
Me.ListEmployeeName.List = dict.Keys
Methode 2: Using Evaluation
Dim lr As Long
Dim arr As Variant
With Sheet1 'Change accordingly
'Find the last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array of unique values
arr = Filter(.Evaluate("TRANSPOSE(If(Row(A1:A" & lr & ")<>MATCH(A1:A" & lr & ",A1:A" & lr & ",0),""|"",A1:A" & lr & "))"), "|", False)
'Add array to Listbox
Me.ListEmployeeName.List = arr
End With
I'm trying to do the following tasks.
Create X-amount of new sheets in DestWorkbook based on row numbers in the Insert_Data_Sheet table. I've solved this
Rename the sheet according to the D-Column data starting from "D2". So I would like to to rename the first sheet "1865727" and the second sheet "1872188" etc. I've solved this
Store the data in D-column in a seperate variables. No luck with this yet
Here is pictures of the data:
https://pasteboard.co/HABwijq.jpg
https://pasteboard.co/HABwEhE.jpg
Full Code:
Public Sub TermSwap()
Application.ScreenUpdating = False
Dim DestWorkbook As Workbook, AC_Live_Workbook As Workbook, AC_Maturity_Workbook As Workbook
Dim Insert_Data_Sheet As Worksheet, AC_Live_Sheet As Worksheet, AC_Maturity_Sheet As Worksheet, Booked_Sheet As Worksheet
Dim i As Long, d As Long, lastRowA_AC_Live As Long, lastRow_AC_Maturity As Long, NumberOfPages As Long
'Dim Swap_Link_Tid As Long
'I will use these in the end when importing the AC Reports
'AC_Live_Filename = Application.GetOpenFilename(, , "AVAA AC LIVE RAPORTTI")
'AC_Maturity_Filename = Application.GetOpenFilename(, , "AVAA AC MATURITY RAPORTTI")
'Insert filename from above lines as a parameter in the end
Set DestWorkbook = Workbooks("TermSwap")
Set AC_Live_Workbook = Workbooks.Open(FileName:="C:\Users\z000479\Desktop\Makrot\Term Swap makro\Harjoitustiedostot\ALL_COLUMNS_FI_180817.xlsx")
Set AC_Maturity_Workbook = Workbooks.Open(FileName:="C:\Users\z000479\Desktop\Makrot\Term Swap makro\Harjoitustiedostot\ALL_COLUMNS_FI_180820.xlsx")
Set Insert_Data_Sheet = DestWorkbook.Sheets("Insert_Data")
Set Booked_Sheet = DestWorkbook.Sheets("booked")
Set AC_Live_Sheet = AC_Live_Workbook.Sheets("Result")
Set AC_Maturity_Sheet = AC_Maturity_Workbook.Sheets("Result")
'Finds the last row in A-Column in the AC_Live_Sheet and AC_Maturity_Sheet
lastRow_AC_Live = AC_Live_Sheet.Cells(AC_Live_Sheet.Rows.Count, "A").End(xlUp).Row
lastRow_AC_Maturity = AC_Maturity_Sheet.Cells(AC_Maturity_Sheet.Rows.Count, "A").End(xlUp).Row
'Create X-amount of new sheets in DestWorkbook based on row numbers in the Insert_Data_Sheet table.SOLVED
' Rename the sheet according to the D-Column data starting from "D2". SOLVED
' Store the data in D-column in a seperate variables. UNSOLVED
NumberOfPages = Insert_Data_Sheet.Cells((Insert_Data_Sheet.Rows.Count), "A").End(xlUp).Row - 1
Dim target_range As String
For d = 2 To NumberOfPages + 1
target_range = Insert_Data_Sheet.Range("D" & d).Value
DestWorkbook.Worksheets.Add(After:=DestWorkbook.Worksheets(DestWorkbook.Worksheets.Count)).Name = target_range
Next d
' AC LIVE Starts here:
' Show all cells
If AC_Live_Sheet.FilterMode Then
AC_Live_Sheet.ShowAllData
End If
'Delete row 2
AC_Live_Sheet.Range("2:2").Delete
'Autofiter ON. Filters LIVE_DEAL and SWAP_LINK_TID. Change SWAP_LINK_TID to a variable.
'Range syntax here is Range ("$A$1:$DS$" & lastRow)
If Not AC_Live_Sheet.AutoFilterMode Then
AC_Live_Sheet.Range("A1").AutoFilter
AC_Live_Sheet.Range("$A$1:$DS$" & lastRow_AC_Live).AutoFilter Field:=1, Criteria1:= _
"LIVE_DEAL"
AC_Live_Sheet.Range("$A$1:$DS$" & lastRow_AC_Live).AutoFilter Field:=7, Criteria1:= _
"1889087"
End If
'Copy pastes visible cells to Booked_Sheet("A1")
With AC_Live_Sheet
.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=Booked_Sheet.Cells(1, 1)
End With
' AC_MATURITY starts here
' Show all cells
If AC_Maturity_Sheet.FilterMode Then
AC_Maturity_Sheet.ShowAllData
End If
'Delete row 2
AC_Maturity_Sheet.Range("2:2").Delete
'Autofiter ON. Filters LIVE_DEAL and SWAP_LINK_TID.
'Range syntax here is Range ("$A$1:$DS$" & lastRow)
'I need to change SWAP_LINK_TID to a variable
If Not AC_Maturity_Sheet.AutoFilterMode Then
AC_Maturity_Sheet.Range("A1").AutoFilter
AC_Maturity_Sheet.Range("$A$1:$DS$" & lastRow_AC_Maturity).AutoFilter Field:=1, Criteria1:= _
"LIVE_DEAL", Operator:=xlOr, Criteria2:="=MAT_DEAL"
AC_Maturity_Sheet.Range("$A$1:$DS$" & lastRow_AC_Maturity).AutoFilter Field:=7, Criteria1:= _
"1889087"
End If
'Copy pastes visible cells to Booked_Sheet("A1")
With AC_Maturity_Sheet
.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=Booked_Sheet.Cells(6, 1)
End With
'Closes AC Workbooks and activates the Booked_Sheet
' Error here. It asked the file to be saved. I want to ignore it.
AC_Live_Workbook.Close
AC_Maturity_Workbook.Close
Booked_Sheet.Activate
Application.ScreenUpdating = True
End Sub
The following is to show how you might load the unique column D numbers into a dictionary as its keys and loop that dictionary's keys to add your new sheets. You could do your filter in the same loop, again using the current key of the dictionary for filtering or use it later. This is not intended to be copy-paste-work but to show you the parts you could use.
Option Explicit
Public Sub test()
Dim valuesDict As Object, arr(), i As Long, lastRow As Long
Set valuesDict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'find last row of your numbers
Select Case lastRow
Case Is < 2
Exit Sub
Case 2 '< Load your number into an array
ReDim arr(1, 1)
arr(1, 1) = .Range("D2")
Case Else
arr = .Range("D2:D" & lastRow).Value
End Select
End With
For i = LBound(arr, 1) To UBound(arr, 1) 'Add unique values to the range
valuesDict(arr(i, 1)) = 1
Next
Dim key As Variant
For Each key In valuesDict.keys
If Not Evaluate("ISREF('" & key & "'!A1)") Then 'If sheet doesn't exist add it. Credit to #Rory for this method.
ThisWorkbook.Worksheets.Add
ActiveSheet.NAME = key
End If
Next key
'Other code.......
For Each key In valuesDict.keys
AC_Live_Sheet.Range("$A$1:$DS$" & lastRow_AC_Live).AutoFilter Field:=7, Criteria1:=key
Next key
'Other code
End Sub
ThisWorkbook.Sheets(1).Range("A1:AR1").AutoFilter Field:=27, _
Criteria1:=Array("<>DRCA", "<>DREX", "<>DRFU", "<>DRIN", _
"<>DRIR", "<>DRND", "<>DRPN", "<>DRPR", "<>DRRE", "<>DRUN", _
"<>REXC", "<>EXCD", "<>RFUR", "<>RINV", "<>RIRC", "<>RNDR", _
"<>RPNA", "<>RPRO", "<>RRET", "<>RUND", "<>RUNF", "<>EXC", "<>C"), _
Operator:=xlFilterValues
This is not returning correct filter data that I want. What I want is that if array doesn't find any <> value then skip it and check next.
How do I go about it?
Excel doesn't allow you to use the array like you want it in the Autofilter. But is there an alternative? Yes!
Logic If I ask you choose numbers between 0 and 10 including 0 and 10 but you cannot choose 0, 5, 8 and 10. So instead of filtering the numbers out and saying I don't want 0, 5, 8 and 10, you can say I want 1,2,3,4,6,7,9.
Similarly in your case we will not filter on the values we DON'T want. We will filter on values we WANT.
So HOW do we find that list and store it in an array?
Find the last row in the relevant column.
Store all records from that column in a unique collection
Check which items in that collection are not in the "exclude" list and create an array.
Filter the range on the values(array) you want! This way we will not have to filter on the values which we don't want.
Code (Tested in Excel 2013 with 50k records)
I have commented the code but if you still have any questions then feel free to ask :)
Dim OmitArray As Variant
Const deLim As String = "|"
Sub Sample()
Dim Ws As Worksheet
Dim lRow As Long, i As Long, n As Long, lCol As Long
Dim Col As New Collection, itm
Dim includeArray As Variant
Dim rng As Range
Dim tmpString As String
'~~> This array has all the values that you want to ignore
OmitArray = Array("DRCA", "DREX", "DRFU", "DRIN", "DRIR", "DRND", _
"DRPN", "DRPR", "DRRE", "DRUN", "REXC", "EXCD", "RFUR", _
"RINV", "RIRC", "RNDR", "RPNA", "RPRO", "RRET", "RUND", _
"RUNF", "EXC", "C")
'~~> This is the column where you want to filter out
lCol = 27
'~~> Change this to the relevant worksheet
Set Ws = ThisWorkbook.Sheets("Sheet1")
With Ws
'~~> Find lastrow
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> This is the range where the filter will be applied
Set rng = .Range("A1:AR" & lRow)
'~~> All all the values from col 27 to a unique collection
For i = 2 To lRow
On Error Resume Next
Col.Add .Cells(i, lCol).Value, CStr(.Cells(i, 27).Value)
On Error GoTo 0
Next i
'~~> Now loop though the collection and store the values in a string
'~~> delimited with a delimiter which arenot present in the "OmitArray"
For Each itm In Col
If Not IsInArray(itm, OmitArray) Then
If tmpString = "" Then
tmpString = itm
Else
tmpString = tmpString & deLim & itm
End If
End If
Next itm
If tmpString <> "" Then
'~~> Split the values based on the delimiter to create array
includeArray = Split(tmpString, deLim)
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter on the rest of the values
With rng
.AutoFilter Field:=lCol, Criteria1:=includeArray, Operator:=xlFilterValues
End With
End If
End With
End Sub
'~~> Function to check if there is an item in the array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Select
End Function
You cannot use the AutoFilter from VBA to explicitly exclude more than two values for a given field. Instead you need to specify the values you want included.
But you do not need to use the AutoFilter to hide the rows containing specific values.
Here is a short routine that will work in your case. You can manage which rows to hide by editing the first line:
Public Sub Demo()
Const HIDE = ".DRCA.DREX.DRFU.DRIN.DRIR.DRND.DRPN.DRPR.DRRE.DRUN.REXC.EXCD.RFUR.RINV.RIRC.RNDR.RPNA.RPRO.RRET.RUND.RUNF.EXC.C."
Dim c As Range
With ThisWorkbook.Sheets(1)
For Each c In .Range("AR1:AR" & .Range("AR" & .Rows.Count).End(xlUp).Row)
If InStr(HIDE, "." & c & ".") Then
c.EntireRow.Hidden = True
End If
Next
End With
End Sub