I've written a script which is supposed to compare the content of column A between two sheets in a workbook to find out if there are partial matches. To be clearer: If any of the content of any cell in coulmn A in sheet 1 matches any of the content of any cell in coulmn A in sheet 2 then that will be a match and the script will print that in immediate window.
This is my attempt so far:
Sub GetPartialMatch()
Dim paramlist As Range
Set paramlist = Sheets(1).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each cel In Sheets(2).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If InStr(1, cel(1, 1), paramlist, 1) > 0 Then 'I used "paramlist" here as a placeholder as I can't use it
Debug.Print cel(1, 1)
End If
Next cel
End Sub
The thing is I can't make use of this paramlist defined within my script. I just used it there as a placeholder.
a very fast approach is given by the use of arrays and Application.Match() function:
Sub GetPartialMatch()
Dim paramlist1 As Variant, paramlist2 As Variant
Dim cel As Range
Dim i As Long
paramlist1 = Sheets(1).Range("A2", Sheets(1).Cells(Rows.Count, 1).End(xlUp)).Value ' collect all sheets(1) column A values in an array
paramlist2 = Sheets(2).Range("A2", Sheets(2).Cells(Rows.Count, 1).End(xlUp)).Value ' collect all sheets(2) column A values in an array
For i = 1 To UBound(paramlist1) ' loop through paramlist1 array row index
If Not IsError(Application.Match(paramlist1(i, 1), paramlist2, 1)) Then Debug.Print paramlist1(i, 1) ' if partial match between current paramlist1 value and any paramlist2 value, then print it
Next
End Sub
if you want an exact match just use 0 as the last parameter in Match() function, i.e.:
If Not IsError(Application.Match(paramlist1(i, 1), paramlist2, 0)) Then Debug.Print paramlist1(i, 1) ' if exact match between current paramlist1 value and any paramlist2 value, then print it
BTW, if you need an exact match you could also use Autofilter() method of Range object with xlFilterValues as its Operator parameter:
Sub GetPartialMatch2()
Dim paramlist As Variant
Dim cel As Range
paramlist = Application.Transpose(Sheets(1).Range("A2", Sheets(1).Cells(Rows.Count, 1).End(xlUp)).Value) ' collect all sheets(1) column A values in an array
With Sheets(2).Range("A1", Sheets(2).Cells(Rows.Count, 1).End(xlUp)) ' reference sheets(2) column A cells from row 1 (header) down to last not empty one
.AutoFilter field:=1, Criteria1:=paramlist, Operator:=xlFilterValues ' filter referenced range with 'paramlist'
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then ' if any filtered cell other then header
For Each cel In .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) ' loop through all sheets(2) filtered cells but the header
Debug.Print cel.Value2
Next
End If
.Parent.AutoFilterMode = False 'remove filter
End With
End Sub
You want a double loop.
Sub GetPartialMatch()
Dim paramlist As Range
Dim cel as Range, cel2 as Range ; declare all variables!
Set paramlist = Sheets(1).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each cel In Sheets(2).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each cel2 in paramlist 'Sheets(1).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If InStr(1, cel(1, 1), cel2, 1) > 0 Then
Debug.Print cel(1, 1)
End If
Next cel2
Next cel
End Sub
Always use Option Explicit. Always.
This may be easier using a helper column and a formula, where the row in the helper column indicates TRUE if a MATCH is found. No VBA then. And it will be inherently faster.
Have you tried adding in:
Application.Screenupdating = false
Application.Calculation = xlCalculationManual
...Code...
Application.Screenupdating = true
Application.Calculation = xlCalculationAutomatic
These turn off the screen updating and automatic calculation of formulas within your instance of excel which can help speed up code a lot, you just have to remember to turn them back on at the end or you might give yourself a bit of a headache. It should be noted, though, that if you turn off screenupdating you won't be able to see the results roll in. You'll have to scroll backwards at the end
Another thing to consider would be store the data in an array before hand and doing the operations to the array and simply pasting it back in to the sheet. Accessing the sheet excessively slows down code drastically. Working with the accepted answer provided by #AJD, I made a few changes that will hopefully speed it up.
Sub macro()
Dim paramlist() As Variant
Dim DataTable() As Variant
Dim cell1 As Variant
Dim cell2 As Variant
paramlist() = Sheets(1).Range("A2:A" & Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row).Value
DataTable() = Sheets(2).Range("A2:A" & Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row).Value
For Each cell1 In paramlist
For Each cell2 In DataTable
If InStr(1, cell2, cell1, 1) > 0 Then
Debug.Print cell1
exit for
End If
Next cell2
Next cell1
End Sub
I would have suggested this under the accepted answer as a suggestion, but unfortunately, I don't have enough rep to comment yet.
Edit: switching the order of the for loops allows you to insert a more efficient exit for and can allow you to skip large portions of data within the search array
Not sure if this is any faster (it uses pretty much the same algorithm, a loop inside of a loop), but I would argue it's a bit clearer:
Sub SearchForPartialMatches()
Dim needle1 As Range, needle2 As Range
Set needle1 = Excel.Worksheets(1).Range("$B$2")
Do While needle1.Value <> ""
Set needle2 = Excel.Worksheets(2).Range("$B$2")
Do While needle2.Value <> ""
If InStr(1, needle1.Value, needle2.Value) > 0 Then
Debug.Print needle1.Value, needle2.Value
End If
Set needle2 = needle2.Offset(rowoffset:=1)
Loop
Set needle1 = needle1.Offset(rowoffset:=1)
Loop
End Sub
The main difference is it's not looping over the entire column, but instead starts at the top, and uses the offset method until there are no more rows (with data).
Of course, you'll need to change the starting cell for needle1 and needle2.
I ran this with the EFF large word list copied into both sheets, and it ran in about 4 minutes (which was less time than with #AJD, but that might've been a fluke). YMMV.
Just one more option. Not much different from any suggestions above ... The concept is to speed up processing by minimizing VBA - Excel interactions by loading the values to arrays and processing arrays like this:
Dim cel as String, cel2 as String
Dim arr1() as String, arr2 As String
arr1 = Sheets(1).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
arr2 = Sheets(2).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each cel In arr1
For Each cel2 in arr2
If InStr(1, cel, cel2, 1) > 0 Then
Debug.Print cel
End If
Next cel2
Next cel
I'd like to know if it helps at all :)
I wanted to write a Excel Macro that goes though K1--->K(lastrow) and looks for the value "OptedOut", and if it finds that value then it deletes that row. I appreciate the help guys. The only part that is wrong is the For Each C part, because I don't understand arrays, and possibly "c.Value = "OptedOut" Then Rows(c).Delete" kinda pulled that out of my ass.
Thanks all!
Sub DuplicateDelete()
Sheets("ALL CLIENTS").Range("A1:J10000").Copy Destination:=Sheets("ClientsAndEmailsThatAreOK").Range("A1:J10000")
With ActiveSheet
LastRow = .Cells(.Rows.Count, "K").End(xlUp).Row
MsgBox LastRow
End With
'Dim c As Range
For Each c In Range(Range(Cells("K1"), Cells(LastRow, "K")))
If c.Value = "OptedOut" Then Rows(c).Delete
Next c
End Sub
Loop backwards when deleting rows (or other objects).
Also, instead of using ActiveSheet try to fully qualify your Worksheet object, such as Sheets("ClientsAndEmailsThatAreOK").
Try the code below, explanation inside the code's comments:
Option Explicit
Sub DuplicateDelete()
Dim C As Range
Dim i As Long, LastRow As Long
Sheets("ALL CLIENTS").Range("A1:J10000").Copy Destination:=Sheets("ClientsAndEmailsThatAreOK").Range("A1:J10000")
' I'm assuming you want to work with sheet "ClientsAndEmailsThatAreOK" (if not then switch it)
With Sheets("ClientsAndEmailsThatAreOK")
LastRow = .Cells(.Rows.Count, "K").End(xlUp).Row
MsgBox LastRow
' always loop backwards when deleting rows
For i = LastRow To 1 Step -1
If .Range("K" & i).Value2 = "OptedOut" Then .Rows(i).Delete
Next i
End With
End Sub
I was wondering if there is a way to filter all the criteria using Autofilter in one go (let say we have three criteria) and copy the data to another worksheet, using VBA.
I'm adding an image for reference.
[]
Using Pivot Table :
Create a Pivot Table
Drag designation to the filter
Employee code to Row Labels
Distance to the values
Finally go to the options tab,
If you want to automate, record these steps.
It is always expected that you try and post the code you tried. Please post your efforts as its encourages people to come out and help you.
I have tried a piece of code to give you an Idea about, Kindly have a look at them and let me know if that works.
Sub autofilter_copy()
'Declare the Required Variables
Dim Colm As Integer
Dim lastrow As Long
Dim i As Variant
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
ws.Activate
'Get Column Number of Designation Column
Colm = WorksheetFunction.Match("Designation", Sheets("Sheet1").Rows(1), 0)
'Get Last row of the Designation Column
lastrow = ActiveSheet.Cells(Rows.Count, Colm).End(xlUp).Row
' Usage of Advanced Filter to get the Unique Values
ActiveSheet.Range("C1:C13").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Sheet1").Range("D1"), Unique:=True
Range("D1").Value = "Designation Unique"
Colm2 = WorksheetFunction.Match("Designation Unique", Sheets("Sheet1").Rows(1), 0)
lastrow2 = ActiveSheet.Cells(Rows.Count, Colm2).End(xlUp).Row
'For loop to loop through the Unique values and paste the values in a new sheet.
For i = 2 To lastrow2
ws.Activate
UniqueValue = Range("D" & i).Value
Cells.Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C" & lastrow).AutoFilter Field:=3, Criteria1:=UniqueValue
Cells.Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ws.Activate
Next
End Sub
I have a VBA Excel code with that checks values in a specific column. If the row in that column contains the value 'Delete' and then deletes the row.
The code works well, but it is really slow. Any ideas on how to get the code run faster?
Dim rng1 As Range
Dim i As Integer, counter As Integer
'Set the range to evaluate to rng.
Set rng1 = Range("g1:g1000")
'initialize i to 1
i = 1
'Loop for a count of 1 to the number of rows
'in the range that you want to evaluate.
For counter = 1 To rng1.Rows.Count
'If cell i in the range1 contains an "Delete"
'delete the row.
'Else increment i
If rng1.Cells(i) = "Delete" Then
rng1.Cells(i).EntireRow.Delete
Else
i = i + 1
End If
Next
Thanks
c.
Sub deletingroutine()
Dim r As Range
For Each r In Range("g1:g1000")
If r = "delete" Then r.EntireRow.Delete
Next r
End Sub
I managed to find a solution with the Autofilter function.
Hope it helps someone
Selection.AutoFilter
Set ws = ActiveWorkbook.Sheets("UploadSummary")
lastRow = ws.Range("G" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("G1:G" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=7, Criteria1:="delete" ' 7 refers to the 7th column
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Try sorting the rows (on collumn G) then deleting all marked ("delete") rows in one action. That is much faster.
I would like to copy a range from a filtered table to another sheet. The starting point is easy however I would like to only copy a number of rows down based on a cell that a user enters into. I can make it work when I hard code the number however I would like to make this based on a cell.
The variable lastrow is where I need to have the cell H4. (H4 in my spreadsheet is where the user keys in the number of rows to copy)
My code thus far is:
Sub Line()
Dim Copyrange As String
Dim lastrow As Range
Startrow = 8
lastrow = 10
Let Copyrange = "B" & Startrow & ":" & "H" & lastrow
Range(Copyrange).Select
End Sub
Any help is really appreciated
Sounds like all you need is this?
Let Copyrange = "B" & Startrow & ":" & "H" & Range("H4")
Changing my answer to the following instead. Not the best of solutions, as working with SpecialCells is tricky at best, but this might suit your needs fairly well.
Sub Illusion()
Dim Source, Dummy As Worksheet
Dim SRow, LRow As Long
Application.ScreenUpdating = False
With ThisWorkbook
Set Source = .ActiveSheet
Set Dummy = .Sheets.Add(After:=Sheets(Sheets.Count))
End With
SRow = 8
LRow = Range("H4").Value + 1
'Change the H10000 below to the correct end row of your unfiltered table.
Source.Range("B" & SRow & ":H10000").SpecialCells(xlCellTypeVisible).Copy
With Dummy
'We create an illusion that we copy only the names we need by bridging using a dummy sheet and copying from there.
.Range("A1").PasteSpecial xlPasteValues
.Range("A1:A" & LRow).Copy
'Paste to desired location as values as well.
.Delete
End With
Application.ScreenUpdating = True
End Sub
What I did here was, we copy the visible cells into a dummy sheet, adjust the number of names to copy from that dummy sheet and do whatever you want with it, then delete the dummy sheet. It's a quick and dirty, but it beats having to go to the intricacies of SpecialCells.