I have a large data sheet that I want to search in VBA based on 3 sets of criteria. Each row entry can be assumed to be unique. The format of the sheet/data itself cannot be changed due to requirements. (I've seen several posts on related questions but haven't found a working solution for this yet.)
At first I used the classic VBA find method in a loop:
Set foundItem = itemRange.Find(What:=itemName, Lookin:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows)
If Not foundItem Is Nothing Then
firstMatchAddr = foundItem.Address
Do
' *Check the other fields in this row for a match and exit if found*
Set foundItem = itemRange.FindNext(foundItem)
Loop While foundItem.Address <> firstMatchAddr And Not foundItem Is Nothing
End If
But because this needs to be called a number of times on large sets of data, the speed of this was no good.
I did some searching and found that I could use the match method with index. So I unsuccessfully tried many variations of that such as:
result = Evaluate("=MATCH(1, (""" & criteria1Name & """=A2:A" & lastRow & ")*(""" & criteria2Name & """=B2:B" & lastRow & ")*(""" & criteria3Name & """=C2:C" & lastRow & "), 0)")
And
result = Application.WorksheetFunction.Index(resultRange, Application.WorksheetFunction.Match((criteria1Name = criteria1Range)*(criteria2Name = criteria2Range)*(criteria3Name = criteria3Range))
And
result = Application.WorksheetFunction.Index(resultRange, Application.WorksheetFunction.Match((criteria1Range=criteria1Name )*(criteria2Range=criteria2Name )*(criteria3Range=criteria3Name ))
Then I tried using AutoFilter to sort:
.Range(.Cells(1,1), .Cells(lastRow, lastCol)).AutoFilter Field:=1, Criteria1:="=" & criteria1Name
.Range(.Cells(1,1), .Cells(lastRow, lastCol)).AutoFilter Field:=2, Criteria1:="=" & criteria2Name
.Range(.Cells(1,1), .Cells(lastRow, lastCol)).AutoFilter Field:=3, Criteria1:="=" & criteria3Name
But because one of the sorting columns contains dates, I had issues getting AutoFilter to work properly.
My question is, how can I search through columns in Excel VBA based on multiple criteria, without looping, returning either the row number or the value in the cell of that row that I am interested in?
You could use an Advanced Filter. Put the column headers in a separate part of the sheet (or a different sheet altogether). Under those column headers, put the criteria you're looking for in each column. Then name that range (including the headers) something like "Criteria". Then the macro becomes:
Sub Macro1()
Sheets("Sheet1").Range("A1").CurrentRegion.AdvancedFilter xlFilterInPlace, Range("Criteria")
End Sub
As a follow up to my comment below, to have the VBA create the criteria range behind the scenes:
Sub Macro1()
'Code up here that defines the criteria
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheets.Add
'Create the advanced filter criteria range
.Range("A1") = "HeaderA"
.Range("B1") = "HeaderB"
.Range("C1") = "HeaderC"
.Range("A2") = criteria1Name
.Range("B2") = criteria2Name
.Range("C2") = criteria3Name
'Alternately, to save space:
'.Range("A1:C1").Value = Array("HeaderA", "HeaderB", "HeaderC")
'.Range("A2:C2").Value = Array(criteria1Name, criteria2Name, criteria3Name)
'Then perform the advanced filter
Sheets("Sheet1").Range("A1").CurrentRegion.AdvancedFilter xlFilterInPlace, .Range("A1:C2")
'Remove behind the scenes sheet now that the filter is completed
.Delete
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
You can use EVALUATE for multiple criteria like so to return the row numbers of mathcing values. This uses the same approach as Is it possible to fill an array with row numbers which match a certain criteria without looping?
It searches 50000 rows to match
the first four letters in column A matches fred
the date in B to be greater than 1/1/2001
apple in column 5
Any rows matching these criteria are retuned as row numbers in x
(rows 1 and 5 in picture below)
code
Sub GetEm2()
x = Filter(Application.Transpose(Application.Evaluate("=IF((LEFT(A1:A10000,4)=""fred"")*(B1:B10000>date(2001,1,1))*(C1:C10000=""apple""),ROW(A1:A10000),""x"")")), "x", False)
End Sub
Application.Transpose is limited to 65536 cells, so a longer range needs to be "chunked" into pieces.
Related
I am trying to copy filtered data from one sheet to another, but for some reason I get a runtime error 1004 saying "to copy all cells from another worksheet to this worksheet make sure you paste them into the first cell (A1 or R1C1)" I actually don't want the header row copied, so all visible bar that row
What I am wanting is the copied data to be pasted to the first available row in the target sheet. Here is the code I have which filters for certain things, but then falls over on the paste line
Sub BBWin()
'
' BB Win Macro
' This macro will filter BB Win 1 - 8
'
With ActiveSheet.Range("A1").CurrentRegion
With .Resize(, .Columns.Count + 1)
With .Cells(2, .Columns.Count).Resize(.Rows.Count - 1)
.FormulaR1C1 = "=if(or(rc7={""K.BB_Win_1_2019"",""K.BB_Win_2_2019"",""K.BB_Win_3_2019"",""K.BB_Win_4_2019"",""K.BB_Win_5_2019"",""K.BB_Win_6_2019"",""K.BB_Win_7_2019"",""K.BB_Win_8_2019""}),""X"","""")"
.Value = .Value
End With
.HorizontalAlignment = xlCenter
End With
Cells.Select
Selection.SpecialCells(xlCellTypeVisible).Copy
Workbooks("Predictology-Reports.xlsx").Sheets("BB Reports").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End Sub
Any suggestions as to what is missing to have it work correctly?
=========================================
OK, perhaps I should have tried the question another way, posting the original working macro I was supplied, rather than posting my attempt to rewrite it.
This is basically the same thing as what I posted above, with the formula changed to look for different text, though it also has autofilter settings (which I don't need) and hides columns (which I don't need to do). This is working perfectly for me and does exactly what it is supposed to. I basically tried to duplicate it and remove the unwanted elements, but as you saw, found the error originally indicated. Obviously my limited knowledge caused the initial issue.
Sub Low_Risk()
'
' Low Risk Lays Macro
' This macro will filter for Remove VDW Rank 1, Class, Distance <=1650, # of Runners <=9, Exclude Brighton, Yarmouth, Windsor & Wolverhampton
'
With ActiveSheet.Range("A1").CurrentRegion
With .Resize(, .Columns.Count + 1)
With .Cells(2, .Columns.Count).Resize(.Rows.Count - 1)
.FormulaR1C1 = "=if(or(rc8={""Brighton"",""Yarmouth"",""Windsor"",""Wolverhampton""}),""X"","""")"
.Value = .Value
End With
.AutoFilter Field:=4, Criteria1:="<=9"
.AutoFilter Field:=11, Criteria1:="<=1650"
.AutoFilter .Columns.Count, "<>X"
.AutoFilter Field:=29, Criteria1:="<>1"
.HorizontalAlignment = xlCenter
End With
.Columns("C:C").EntireColumn.Hidden = True
.Columns("G:G").EntireColumn.Hidden = True
.Columns("I:I").EntireColumn.Hidden = True
.Columns("L:L").EntireColumn.Hidden = True
.Columns("N:W").EntireColumn.Hidden = True
.Columns("Y:AB").EntireColumn.Hidden = True
.Columns("AD:AJ").EntireColumn.Hidden = True
.Columns("AO:AO").EntireColumn.Hidden = True
.Columns("AQ:BQ").EntireColumn.Hidden = True
.Columns("BT:CP").EntireColumn.Hidden = True
.Parent.AutoFilter.Range.Offset(1).Copy
Workbooks("New Results File.xlsm").Sheets("Low Risk Lays").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End Sub
As indicated, this works absolutely perfectly, nested Withs and all. I can change the original formula so it is looking in the correct column and only for the text I want, but I obviously was not able to successfully remove the autofilter elements and the elements which hide columns without bringing up an error. I assume the removal of the .Parent.AutoFilter.Range.Offset(1).Copy line was the culprit, but wasn't sure how to approach the removal of the unwanted elements.
This original macro was supplied to me in one of the forums and I am loath to alter the formula part which does a good job of looking for the many text elements required to be copied. That was why I only looked to alter the autofilter section and hidden column section
I'm not sure if this helps at all, but it may clarify things a little
cheers and thanks so much for your effort
Cells.Select (with no leading period to tie it to the With block) will select all cells on whatever is the active sheet.
Try this (nested With's confuse me a bit, so removed a couple)
Sub BBWin()
Dim arr, ws As Worksheet, lc As Long, lr As Long
arr = Array("K.BB_Win_1_2019", "K.BB_Win_2_2019", "K.BB_Win_3_2019", _
"K.BB_Win_4_2019", "K.BB_Win_5_2019", "K.BB_Win_6_2019", _
"K.BB_Win_7_2019", "K.BB_Win_8_2019")
Set ws = ActiveSheet
'range from A1 to last column header and last row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With ws.Range("A1", ws.Cells(lr, lc))
.HorizontalAlignment = xlCenter
.AutoFilter Field:=7, Criteria1:=arr, Operator:=xlFilterValues
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
End With
Workbooks("Predictology-Reports.xlsx").Sheets("BB Reports") _
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
Cells.Select selects all sheets cells.
Selection.SpecialCells(xlCellTypeVisible) keeps all cells, since nothing is hidden and everything is visible. You said something about "copy filtered data" but your code does not filter anything...
So, there is not place to paste all cells.
In order to make your code working, replace Cells.Select with .Cells.Select (the dot in front makes it referring to the resized UsedRange). Even if any selection is not necessary...
So, (better) use .cells.SpecialCells(xlCellTypeVisible).Copy...
Edited:
Your last code needs to only copy the visible cells of the filtered range. So, your code line
.Parent.AutoFilter.Range.Offset(1).Copy
must be replaced by the next one:
.Parent.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Copy
or
.Offset(1).SpecialCells(xlCellTypeVisible).Copy
which refers the processed range (`UsedRange'), starting from the second row.
What I am wanting is the copied data to be pasted to the first
available row in the target sheet.
You should define your available row to paste your fillered rows in, or first blank row in the sheet you want the filtered data pasted. Then you will be able to paste your data into that row.
In my example, I'm filtering my datawork (source sheet) sheet by anything in col 24 that contains "P24128" and pasting into "Sheet8" (Target sheet), in my example.
I actually don't want the header row copied, so all visible bar that
row
You also didnt want the headers. :)
Sub CopyFilteredDataSelection10()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Datawork")
ws.Activate
'Clear any existing filters
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
'1. Apply Filter
ActiveSheet.Range("A1:ADU5000").AutoFilter Field:=24, Criteria1:="*P24128*" ' "*" & "P24128" & "*" ' im filtering by anything in col 24 that contains "P24128"
'2. Copy Rows minus the header
Application.DisplayAlerts = False
ws.AutoFilter.Range.Copy 'copy the AF first
Set Rng = ws.UsedRange.Offset(1, 0)
Set Rng = Rng.Resize(Rng.Rows.Count - 1)
Rng.Copy
'3. The Sheet & Where you want to paste the filtered data precisely into Sheet x (Sheet 8 in my example)
Sheets("Sheet8").Activate
lr = ThisWorkbook.Worksheets("Sheet8").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1
Range("A" & lr).Select
ActiveSheet.Paste
Application.DisplayAlerts = True
'4. Clear Filter from original sheet
On Error Resume Next
ws.Activate
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
What does the not-including the headers is this
ws.AutoFilter.Range.Copy 'copy the AutoFilter first
Set Rng = ws.UsedRange.Offset(1, 0)
Set Rng = Rng.Resize(Rng.Rows.Count - 1)
Rng.Copy
& your target is after you activate the target sheet and find its last row
lr = ThisWorkbook.Worksheets("Sheet8").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1
I'm using the alteration of the code from Scott Craner (which works perfectly). However, now I would like VBA to match criteria not only from one column but from 2 columns and then copy/paste as formulas to the next sheet.
Sub TransferRows()
Dim lLRow As Long
With Sheets("Sheet1")
lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("B:B").AutoFilter Field:=1, Criteria1:="Cat"
.Range("B2:B" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlFormulas
.AutoFilterMode = False
End With
End Sub
Criteria1 in column "B" is "Cat", I need to add another Criteria2 ("dog") from column "C". So whenever I have "Cat" in "B" and "Dog" in "C" the entire rows are copied to Sheet2. PS. Bear in mind that I have various types of data in columns "B" and "C" so filters are imperative (also since there are 10's of thousands of rows I can't use the loop as it takes too long). Thus I would welcome advice on how to add another criteria to the aforementioned code.
Thanks
West
Try the code below (see comments inside the code):
Option Explicit
Sub TransferRows()
Dim lLRow As Long
With Sheets("Sheet1")
lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Range("B1:C" & lLRow)
.AutoFilter Field:=1, Criteria1:="Cat"
.AutoFilter Field:=2, Criteria1:="dog"
End With
.Range("B2:C" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
' rest of your code goes here
End With
End Sub
My data looks like this.
I would like to delete rows where the value in column named Position from first has value 1. I wrote a macro to do that which is like this
Sub DEL_row()
row_number = 2
Do
DoEvents
row_number = row_number + 1
Position_from_first = Sheet8.Range("E" & row_number)
If InStr(Position_from_first, "1") >= 1 Then
Sheet8.Rows(row_number & ":" & row_number).Delete
End If
Loop Until Position_from_first = ""
MsgBox "completed"
End Sub
But when i run it, I get an error. The msg box says completed but it does not do the required job when I go through the excel sheet.
Can anyone help me what the problem would be.
Thanks a lot for helping...
While your concept is spot on, there are some errors in your syntax and your understanding of VBA. I have listed them below.
No need for Do Events in this code at all.
When deleting rows, you need to start from the last row and step back to the beginning in your looping because as you soon as you delete a row it affects all the row references below that, so your loop count will miss rows if you go forward.
You also need to use .EntireRow.Delete. .Delete will only delete cell content.
I have fixed your code below to reflect these issues. I have also provided a simpler alternative to solve your problem below that which uses the AutoFilter method.
Sub DEL_row()
'get last used row in column E
row_number = Sheet8.Range("E" & Sheet8.Rows.Count).End(xlup).Row
For x = row_number to 2 Step -1
Position_from_first = Sheet8.Range("E" & row_number)
If InStr(Position_from_first, "1") >= 1 Then
'If Sheet8.Range("E" & row_number) = 1 ' this will also work
Sheet8.Rows(row_number & ":" & row_number).EntireRow.Delete
End If
Next
MsgBox "completed"
End Sub
You can avoid the loop altogether (and save time) if you use AutoFilter, like this:
Sub DEL_row()
With Sheet8
'get last used row in column E
row_number = .Range("E" & .Rows.Count).End(xlup).Row
With .Range("E1:E" & row_number)
.AutoFilter 1, "1"
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
End With
Msgbox "completed"
End Sub
I gather that you do not want to delete 11, 12, 31, ... etc. so using the InStr function is not an appropriate method of identifying the correct rows to delete. Your sample data image shows column E as having true, right-aligned numbers and the Range.Value2 property can be directly compared against a 1 to determine if the row should be removed.
As mentioned, working from the bottom to the top is important when deleting rows. If you work from the top to the bottom you risk skipping a row when a row has been deleted, everything shifts up and then you increment to the next row.
Option Explicit
Sub DEL_1_rows()
'declare your variables
Dim rw As Long
'this will greatly improve the speed involving row deletion
Application.ScreenUpdating = False
With sheet8 '<~~ this is a worksheet CodeName - see below
For rw = .Cells(Rows.Count, 5).End(xlUp).Row To 2 Step -1
If .Cells(rw, 5).Value2 = 1 Then .Rows(rw).EntireRow.Delete
Next rw
End With
Application.ScreenUpdating = True
MsgBox "completed"
End Sub
An AutoFilter Method can speed up identifying the rows to delete. However, a single large bulk deletion can still take a significant amount of processing time.
Option Explicit
Sub DEL_Filtered_rows()
'this will greatly improve the speed involving row deletion
Application.ScreenUpdating = False
With Sheet8 '<~~ this is a worksheet CodeName - see below
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(1, 5), .Cells(Rows.Count, 5).End(xlUp))
.AutoFilter field:=1, Criteria1:=1
With .Resize(.Rows.Count, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
End With
.AutoFilter
End With
End With
Application.ScreenUpdating = True
MsgBox "completed"
End Sub
I found it a little odd that you were identifying the worksheet with a Worksheet .CodeName property rather than a Worksheet .Name property. I've included a couple of links to make sure you are using the naming conventions correctly. In any event, I've use a With ... End With statement to avoid repeatedly reidentifying the parent worksheet.
I’ve got the following bit of code that copies rows from one sheet to another if it is the same region that has been selected in a combo box. The problem I have is that it is copying into row 5 rather than row 6 and copying over the column titles. Do you know why this might be happening? I thought the fourth line starting "Worksheets("NLE_").Range("A")... would pick the first empty row i.e. A6, but it picks A5?
If chkNLE.Value = True And cboLA = "All" Then
LastRow = Worksheets("NLE_").Range("A" & Rows.Count).End(xlUp).Row *– clears any data that is already in the worksheet*
Worksheets("NLE_").Range("A6:W" & LastRow).Clear
For Each i In Sheets("NLE").Range("NLEregion") *– NLEregion is a named range for the column with region in it in the sheet when the data is being copied from*
If i.Value = cboRegion.Value Then
i.EntireRow.Copy
Worksheets("NLE_").Range("A" & Rows.Count).End(xlUp).Offset (1)
Sheets("NLE_").Visible = True
Sheets("Front Page").Visible = False
UserForm1.Hide
End If
Next i
End If
Thanks for the suggestion #Siddarth Rout. I went away and worked out how to use Autofilter to do this and it is much quicker than my previous code, which at work was a little slow becasue we are on a thin client.
There maybe a more efficient way of doing this as I am new to VBA but this does work.
If chkNLE.Value = True And cboLA = "All" And cboLA <> "" And cboRegion <> "All" Then
Application.ScreenUpdating = False 'stops the screen from updating while copying and pasting
LR = Sheets("NLE").Range("A" & Rows.Count).End(xlUp).row ' sets LR to the last cell number in A
Set rng = Sheets("NLE").Range("A5:V" & LR) ' Sets rng from A5 to the last cell in column V - includes second row of titles
With rng
.AutoFilter
.AutoFilter Field:=13, Criteria1:=cboRegion.Value 'filters on the region selected in the drop down box
.SpecialCells(xlCellTypeVisible).Copy 'copies just the filtered data
End With
Sheets("NLE_").Range("A5").PasteSpecial xlPasteAll 'pastes just the filtered data into NLE_
Sheets("NLE").AutoFilterMode = False
Application.CutCopyMode = False
Sheets("NLE_").Range("A5:V5").AutoFilter 'Adds the filter back to NLE_
Sheets("NLE").Range("A5:V5").AutoFilter
Application.ScreenUpdating = True 'allows the screen to update
I am trying to delete entire rows with duplicate values. If the values in column "E" are the same in two rows, I want to delete all row with that value that is duplicated.
The other fields might be or not duplicates of that row and there might be up to ten duplicates and the total number of rows is large ( #rows >4000). This is just one part of a large macro, so I cannot use excel functions. This is what I have so far for deleting rows:
Sub AAAAH()
Application.ScreenUpdating = False
Dim i As Single
Dim j As Single
BottomLineRelease = Sheets("Hours Of Interest").Range("E" & Rows.Count).End(xlUp).Row + 1
rowcount = Sheets("Hours Of Interest").Range("E2:E" & BottomLineRelease).Rows.Count
For i = 2 To Sheets("Hours Of Interest").Cells(Rows.Count, "E").End(xlUp).Row
If Sheets("Hours Of Interest").Range("E" & i) = Sheets("Hours Of Interest").Range("E" & i - 1) Then
j = i - 1
Rows(j).Select
Selection.delete Shift:=xlUp
End If
Next i
Application.ScreenUpdating = True
End Sub
This not only crashes Excel, but the "Selection.delete Shift: =xlup" will not allow the "delete" to stay capitalized. Every time I click away, it goes back to lower case.
Does anyone know a faster or at least functional way to delete these duplicate rows in VBA?
Selection (=Application.Selection) is declared only as Object because it can take various objects (a range, a shape object, a chart etc. etc.). Therefore the intellisense doesn't work as well, it is only determined during execution if .Delete is a valid method.
Try
Sheets("Hours Of Interest").Rows(j).Delete Shift:=xlUp
If you use Sheets(...).Range in your code, you should never get lazy and never use Range or Rows or Cells without that explicit reference, you might be deleting on a different worksheet.
Furthermore, if you delete rows from the top down, every delete changes the row numbers of the following lines.
So you should delete backwars with
for i = [..maximum..] to 0 step -1
You don't need a loop to isolate unique values. You can filter column E for unique values, copy those to a new sheet, and delete the old sheet.
lastRow = Range("A1000000").End(xlUp).Row
Range("A1:H" & lastRow).AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=Range("E1:E" & lastRow), Unique:=True
Cells.Copy
Sheets.Add
ActiveSheet.Paste
Application.DisplayAlerts = False
Sheets("oldSheet").Delete
Application.DisplayAlerts = True
This is way faster than a loop, if memory serves.