Evaluate a list of values in a column against a combobox value most efficiently - excel

I am trying to delete duplicate values in a temporary list based on a value in a combobox. The code below loops through individual rows to check whether a value matches. It is slow.
Dim ws As Worksheet
Dim i As Long
Set ws = Sheets("TempList3")
On Error Resume Next
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Cells(i, 2) <> Sheets("Sheet1").ComboBox2.Value Then
ws.Rows(i).EntireRow.Delete
End If
Next
Is there a way to evaluate the entire column's values against the combobox's value once and then delete all rows on a worksheet. Or perhaps there is a better way?

I used a looping Find function, it deletes the row where the value was found and then it searches again and deletes the next row it finds until it can no longer find the Combo value on the sheet:
Sub find_cell()
Dim find_cell As Range
Set ws = Sheets("TempList3")
stop_loop = False
Do Until stop_loop = True
Set find_cell = ws.Cells.Find(What:=Sheets("Sheet1").ComboBox2.Value, LookAt:=xlWhole)
If Not find_cell Is Nothing Then
ws.Rows(find_cell.Row).EntireRow.Delete
Else
stop_loop = True
End If
Loop
End Sub

Not knowing how many rows you are talking about, I used 10 thousand for my example codes. here are two examples, try the both and see what works best for you.
You can run through the column and unionize the range found, then delete the rows, for example.
See here for example workbook
Sub UnIonRng()
Dim FrstRng As Range
Dim UnIonRng As Range
Dim c As Range, s As String
s = Sheets("Sheet1").ComboBox2
Set FrstRng = Range("B:B").SpecialCells(xlCellTypeConstants, 23)
For Each c In FrstRng.Cells
If c = s Then
If Not UnIonRng Is Nothing Then
Set UnIonRng = Union(UnIonRng, c) 'adds to the range
'MsgBox UnionRng.Address 'remove later
Else
Set UnIonRng = c
End If
End If
Next c
UnIonRng.EntireRow.Delete
End Sub
Or you can try to filter the column B and delete the rows that way:
Sub FilterDeleteRow()
Dim ws As Worksheet
Dim LstRw As Long, Rng As Range, s As String, x
Set ws = Sheets("TempList3")
s = Sheets("Sheet1").ComboBox2
Application.ScreenUpdating = 0
With ws
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
x = Application.WorksheetFunction.CountIf(.Range("B:B"), s)
If x > 0 Then
Columns("B:B").AutoFilter Field:=1, Criteria1:=s
Set Rng = .Range("B2:B" & LstRw).SpecialCells(xlCellTypeVisible)
Rng.EntireRow.Delete
.AutoFilterMode = 0
Else: MsgBox "Not Found"
End If
End With
End Sub

Related

How to Automate my Manual Selection Process in VBA

I have a manual selection process that I have tried but failed to automate, so I am reaching out for help. I have attached an image of my Excel sheet as a visual guide when reading my process. Excel Snapshot.
I select cell "L2" and run the code below. It finds the first instance of the value within "A2:J1501" and cuts the whole row. It pastes the row onto the sheet named Lineups. Then it highlights each of the values of the cut row in column "L:L" to let me know that value has been used. I then manually select the next non-highlighted value (in the image example it would be "L2") and run the code again, and again, and again, until every row of L:L is highlighted. This process can take some time depending on the number of rows in L:L so I was hoping I can get some help to automate.
Thank you very much.
Sub ManualSelect()
Dim rng As Range
Set rng = Range("A1:J1501")
Dim ac As Range
Set ac = Application.ActiveCell
rng.Find(what:=ac).Select
Range("A" & ActiveCell.Row).Resize(1, 10).Cut
ActiveWindow.ScrollRow = 1
Sheets("Lineups").Select
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).Select
ActiveSheet.Paste
Sheets("Data").Select
Dim wsData As Worksheet
Dim wsLineups As Worksheet
Dim rngToSearch As Range
Dim rngLineupSet As Range
Dim rngPlayerID As Range
Dim Column As Long
Dim Row As Long
Dim LastRow As Long
Set wsData = Sheets("Data")
Set wsLineups = Sheets("Lineups")
Set rngPlayerID = wsData.Range("L2:K200")
Set rngToSearch = rngPlayerID
LastRow = wsLineups.Cells(Rows.Count, 1).End(xlUp).Row
For Row = 2 To LastRow
For Column = 1 To 10
Set rngLineupSet = rngPlayerID.Find(what:=wsLineups.Cells(Row, Column), LookIn:=xlValues)
If Not rngLineupSet Is Nothing Then rngLineupSet.Interior.Color = 65535
Next Column
Next Row
End Sub
This should be pretty close:
Sub ManualSelect()
Dim wsData As Worksheet, c As Range, dict As Object, v, rw As Range
Dim wsLineups As Worksheet, c2 As Range, f As Range
Set dict = CreateObject("scripting.dictionary") 'for tracking already-seen values
Set wsLineups = ThisWorkbook.Worksheets("Lineups")
Set wsData = ThisWorkbook.Worksheets("Data")
For Each c In wsData.Range("L2", wsData.Cells(Rows.Count, "L").End(xlUp))
v = c.Value
If dict.exists(CStr(v)) Then
c.Interior.Color = vbYellow 'already seen this value in L or a data row
Else
'search for the value in
Set f = wsData.Range("A2:J1501").Find(v, lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows)
If Not f Is Nothing Then
Set rw = f.EntireRow.Columns("A").Resize(1, 10) 'A to J
For Each c2 In rw.Cells 'add all values from this row to the dictionary
dict(CStr(c2)) = True
Next c2
rw.Cut Destination:=wsLineups.Cells(Rows.Count, "A").End(xlUp).Offset(1)
c.Interior.Color = vbYellow
Else
'will there always be a match?
c.Interior.Color = vbRed 'flag no matching row
End If
End If 'haven't already seen this col L value
Next c 'next Col L value
End Sub
I believe this should do it (updated):
Sub AutoSelect()
Dim wsData As Worksheet, wsLineups As Worksheet
Dim rng As Range, listIDs As Range
Set wsData = ActiveWorkbook.Sheets("Data")
Set wsLineups = ActiveWorkbook.Sheets("Lineups")
Set rng = wsData.Range("A2:J1501")
'get last row col L to define list
LastRowL = wsData.Range("L" & Rows.Count).End(xlUp).Row
Set listIDs = wsData.Range("L2:L" & LastRowL)
'loop through all cells in list
For i = 1 To listIDs.Rows.Count
myCell = listIDs.Cells(i)
'retrieve first mach in listID
checkFirst = Application.Match(myCell, listIDs, 0)
'only check first duplicate in list
If checkFirst = i Then
'get new row for target sheet as well (if sheet empty, starting at two)
newrow = wsLineups.Range("A" & Rows.Count).End(xlUp).Row + 1
'check if it is already processed
Set processedAlready = wsLineups.Cells(2, 1).Resize(newrow - 1, rng.Columns.Count).Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'if so, color yellow, and skip
If Not processedAlready Is Nothing Then
listIDs.Cells(i).Interior.Color = vbYellow
Else
'get fist match for value, if any (n.b. "xlWhole" ensures whole match)
Set foundMatch = rng.Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'checking for a match
If Not foundMatch Is Nothing Then
'get the row
foundRow = foundMatch.Row - rng.Cells(1).Row + 1
'specify target range and set it equal to vals from correct row in rng
wsLineups.Cells(newrow, 1).Resize(1, rng.Columns.Count).Value2 = rng.Rows(foundRow).Value
'clear contents rng row
rng.Rows(foundRow).ClearContents
'give a color to cells that actually got a match
listIDs.Cells(i).Interior.Color = vbYellow
Else
'no match
listIDs.Cells(i).Interior.Color = vbRed
End If
End If
Else
'duplicate already handled, give same color as first
listIDs.Cells(i).Interior.Color = listIDs.Cells(checkFirst).Interior.Color
End If
Next i
End Sub
Also, I think, slightly faster than the other solution offered (because of the nested loop there?). Update: I got a bit confused about the nested loop in the answer by Tim Williams, but I missed that you also want to "accept" the values in the list that matched on a row that is already gone. I fixed this in the updated version by checking if a value that fails to match on the data range has already been transferred to Lineups. Provided that doing so is permissible, this method avoids the nested loop.
I checked both methods for speed (n = 50) on a list (n = 200) for the full data range, ended up with average of 1.70x faster... But maybe speed is not such a big deal, if you're coming from manual labor :)

Excel VBA - Delete empty columns between two used ranges

I would like to delete all empty columns between 2 used ranges, based on the screenshot:
However, these two used ranges may have varying column length, thus the empty columns are not always Columns D to K.
Here is my code:
Sub MyColumns()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open ("BOOK2.xlsx")
Workbooks("BOOK2.xlsx").Activate
Workbooks("BOOK2.xlsx").Sheets(1).Activate
Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, 4).Value = "NON-EMPTY"
Dim finalfilledcolumn As Long
finalfilledcolumn = Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Dim iCol As Long
Dim i As Long
iCol = firstfilledcolumn + 1
'Loop to delete empty columns
For i = 1 To firstfilledcolumn + 1
Columns(iCol).EntireColumn.Delete
Next i
Workbooks("BOOK2.xlsx").Close SaveChanges:=True
MsgBox "DONE!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
However, the empty columns still remain.
Do note that the last filled column for the first used range, Place = "USA", Price = "110" and Category = "Mechanical" may not be fixed at Column C, but could go to Column D, E, etc.
Many thanks!
Please, try the next way:
Sub deleteEmptyColumn()
Dim sh As Worksheet, lastCol As Long, rngColDel As Range, i As Long
Set sh = ActiveSheet 'use here your necessary sheet, having the workbook open
'if not open, you can handle this part...
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column
For i = 1 To lastCol
If WorksheetFunction.CountA(sh.Columns(i)) = 0 Then
If rngColDel Is Nothing Then
Set rngColDel = sh.cells(1, i)
Else
Set rngColDel = Union(rngColDel, sh.cells(1, i))
End If
End If
Next i
If Not rngColDel Is Nothing Then rngColDel.EntireColumn.Delete
End Sub
Try this ..
Dim rng As Range, i As Long
Set rng = Workbooks("BOOK2.xlsx").Sheets(1).UsedRange
For i = rng.Columns.Count To 1 Step -1
If WorksheetFunction.CountA(rng.Columns(i)) = 0 Then
rng.Columns(i).EntireColumn.Delete
End If
Next i

Excel VBA Hidding rows by comparing two Cells

I have a question about how to use a double loop to compare two Cells which are located in different sheets("Sheet1" and "Sheet2").
The condition I want to apply to the Loop is that in case if the two cells are different, the row must be hidden (Applied to the table located in Sheet1). In the contrary case, if the two cells are the same, the row stays as it is by default.
But with the Macro I wrote, it hides all rows that form the Sheet1 table. What could be the reason?
Sub HideRows()
Sheets("Sheet2").Select
Dim NR As Integer
NR = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
Sheets("Sheet1").Select
Dim i As Integer, j As Integer
For i = 2 To 10
For j = 1 To NR
If Cells(i, 1) <> Sheets("Sheet2").Cells(j, 1) Then
Rows(i & ":" & i).Select
Selection.EntireRow.Hidden = True
End If
Next j
Next I
End Sub
Sheet1:
Sheet2:
Desired result:
Your task is better described as
Hide all rows on Sheet1 whose column A value does not apear on Sheet2 column A
Using the looping the ranges technique you tried, this could be written as
Sub HideRows()
Dim rng1 As Range, cl1 As Range
Dim rng2 As Range, cl2 As Range
Dim HideRow As Boolean
With ThisWorkbook.Worksheets("Sheet1")
Set rng1 = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
rng1.EntireRow.Hidden = False
For Each cl1 In rng1.Cells
HideRow = True
For Each cl2 In rng2.Cells
If cl1.Value2 = cl2.Value2 Then
HideRow = False
Exit For
End If
Next
If HideRow Then
cl1.EntireRow.Hidden = True
End If
Next
End Sub
That said, while this approach is ok for small data sets, it will be slow for larger data sets.
A better approach is to loop Variant Arrays of the data, and build a range reference to allow hiding all required rows in one go
Sub HideRows2()
Dim rng1 As Range, cl1 As Range, dat1 As Variant
Dim rng2 As Range, cl2 As Range, dat2 As Variant
Dim HideRow As Boolean
Dim r1 As Long, r2 As Long
Dim HideRange As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
dat1 = rng1.Value2
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
dat2 = rng2.Value2
End With
rng1.EntireRow.Hidden = False
For r1 = 2 To UBound(dat1, 1)
HideRow = True
For r2 = 1 To UBound(dat2, 1)
If dat1(r1, 1) = dat2(r2, 1) Then
HideRow = False
Exit For
End If
Next
If HideRow Then
If HideRange Is Nothing Then
Set HideRange = rng1.Cells(r1, 1)
Else
Set HideRange = Application.Union(HideRange, rng1.Cells(r1, 1))
End If
End If
Next
If Not HideRange Is Nothing Then
HideRange.EntireRow.Hidden = True
End If
End Sub
#Chjris Neilsen has beaten me to most of what I wanted to mention. Please refer to his comment above. However, there are two things I want to add.
Please don't Select anything. VBA knows where everything is in your workbook. You don't need to touch. Just point.
i and j aren't really meaningful variable identifiers for Rows and Columns. They just make your task that much more difficult - as if you weren't struggling with the matter without the such extra hurdles.
With that out of the way, your code would look as shown below. The only real difference is the Exit For which ends the loop when the decision is made to hide a row. No guarantee that the procedure will now do what you want but the logic is laid are and shouldn't be hard to adjust. I point to .Rows(C).Hidden = True in this regard. C is not a row. It's a column.
Sub HideRows()
' always prefer Long datatype for rows and columns
Dim Rl As Long ' last row: Sheet2
Dim C As Long ' loop counter: columns
Dim R As Long ' loop counter: rows
Rl = WorksheetFunction.CountA(Sheet2.Columns(1))
With Sheet1
For C = 2 To 10
For R = 1 To Rl
' always list the variable item first
If Sheets("Sheet2").Cells(R, 1).Value <> .Cells(C, 1).Value Then
.Rows(C).Hidden = True
Exit For
End If
Next R
Next C
End With
End Sub

Conditional formatting/testing headers against prescribed header list (Excel-VBA)

I use VBA rarely and am always re-learning. This is my first posting.
I am using OCR to pull in tables from PDFs to individual worksheets (usually 100-200 tabs) and I have VBA programming ready to consolidate the data based on header values. But the headers are error prone and need to be reviewed first. I want to run a VBA macro that tests headers in row 1 against a set list and highlight those headers that exactly match.
I found a great start with Conditional formatting over huge range in excel, using VBA (Dictionary Approach) which tests lists, but I am struggling to convert the code to handle rows instead of columns. (Next I plan to have it run on every tab in the workbook, but am stuck at the testing stage).
Here is my current edit of the original code to pull from rows, but I get a subscript out of range on If dict2.Exists(vals(i)) Then
Option Explicit
Sub main3()
Dim mainRng As Range, list1Rng As Range
Dim mainDict As New Scripting.Dictionary, list1Dict As New
Scripting.Dictionary 'Main is Header and list1 is prescribed header list
Set mainRng = GetRange(Worksheets("Main"), "1") '<--| get "Main" sheet row "1" range from column A right to last non empty column
Set list1Rng = GetRange(Worksheets("list1"), "1") '<--| get "list1" sheet row "1" range from column A right to last non empty column
Set mainDict = GetDictionary(mainRng)
Set list1Dict = GetDictionary(list1Rng)
ColorMatchingRange2 list1Rng, list1Dict, mainDict
End Sub
Sub ColorMatchingRange2(rng1 As Range, dict1 As Scripting.Dictionary, dict2 As Scripting.Dictionary)
Dim unionRng As Range
Dim vals As Variant
Dim i As Long
vals = rng1.Value 'oringinal code transposed with = Application.Transpose(rng1.Value)
Set unionRng = rng1.Offset(rng1.Rows.Count).Resize(1, 1)
For i = LBound(vals) To UBound(vals)
If dict2.Exists(vals(i)) Then Set unionRng = Union(unionRng, rng1(1, i))
Next i
Set unionRng = Intersect(unionRng, rng1)
If Not unionRng Is Nothing Then
With unionRng.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End If
End Sub
Function GetDictionary(rng As Range) As Scripting.Dictionary
Dim dict As New Scripting.Dictionary
Dim vals As Variant
Dim i As Long
vals = rng.Value 'oringinal code transposed with=Application.Transpose(rng.Value)
On Error Resume Next
For i = LBound(vals) To UBound(vals)
dict.Add vals(i), rng(1, i).Address
Next i
On Error GoTo 0
Set GetDictionary = dict
End Function
Function GetRangeRow(ws As Worksheet, rowIndex As String) As Range
With ws '<--| reference passed worksheet
Set GetRangeRow = .Range("A" & rowIndex, .Cells(1, .Columns.Count).End(xlToLeft)) '<--| set its row "rowIndex" range from row 1 right to last non empty column
End With
End Function
More background, the VBA will be in a Control Workbook with the set header list, and the code will run on the ActiveWorkbook which will be the data across many worksheets, but I believe I've got that figured out.
Simpler approach:
Sub HighlightMatchedHeaders()
Dim rngList As Range, c As Range, v
Dim sht As Worksheet, wb As Workbook
Set wb = ActiveWorkbook 'or whatever
'set the lookup list
With wb.Sheets("list")
Set rngList = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
For Each sht In wb.Worksheets
'ignore the "list" sheet
If sht.Name <> rngList.Worksheet.Name Then
'checking row 1
For Each c In Application.Intersect(sht.Rows(1), sht.UsedRange).Cells
v = Trim(c.Value)
If Len(v) > 0 Then
'has a header: check for match
If Not IsError(Application.Match(v, rngList, 0)) Then
c.Interior.Color = vbRed 'show match
End If
End If
Next c
End If
Next sht
End Sub

Copying data which less than 100 times repeated in column - Excel-VBA

Having very huge excel data. I want to copy the data from column C to other sheet with condition. C column having n number of text values want to take only which word contains less than 100 times repeatedly.
Sub DelR()
Dim myRow As Range
Dim to Delete As Range
For I=2 to 10000
If workseets("Sheet1").Cells(I,2) >100 Then
Set myRow = Worksheets("Sheet1").Rows(I)
If toDelete = myRow Else
Set to Delete = Union(toDelete, myRow)
End If
End If
Next I
If Not toDelete Is Nothing Then toDelete.EntireRow.Delete
End Sub
Sub DelR()
Dim sht As WorkSheet
Dim myRow As Range
Dim to Delete As Range
Set sht = worksheets("Sheet1")
For I=2 to 10000
If Application.Countif(sht.Columns(2), _
sht.Cells(I,2).Value) >100 Then
Set myRow = sht.Rows(I)
If toDelete Is Nothing
Set toDelete = myRow
Else
Set toDelete = Application.Union(toDelete, myRow)
End If
End If
Next I
If Not toDelete Is Nothing Then toDelete.EntireRow.Delete
End Sub

Resources