Excel VBA cut and paste a dynamic range of cells [duplicate] - excel

I would like to delete the empty rows my ERP Quotation generates. I'm trying to go through the document (A1:Z50) and for each row where there is no data in the cells (A1-B1...Z1 = empty, A5-B5...Z5 = empty) I want to delete them.
I found this, but can't seem to configure it for me.
On Error Resume Next
Worksheet.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

How about
sub foo()
dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.Range("A1:Z50")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub

Try this
Option Explicit
Sub Sample()
Dim i As Long
Dim DelRange As Range
On Error GoTo Whoa
Application.ScreenUpdating = False
For i = 1 To 50
If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
If DelRange Is Nothing Then
Set DelRange = Range("A" & i & ":" & "Z" & i)
Else
Set DelRange = Union(DelRange, Range("A" & i & ":" & "Z" & i))
End If
End If
Next i
If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
IF you want to delete the entire row then use this code
Option Explicit
Sub Sample()
Dim i As Long
Dim DelRange As Range
On Error GoTo Whoa
Application.ScreenUpdating = False
For i = 1 To 50
If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
If DelRange Is Nothing Then
Set DelRange = Rows(i)
Else
Set DelRange = Union(DelRange, Rows(i))
End If
End If
Next i
If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub

I know I am late to the party, but here is some code I wrote/use to do the job.
Sub DeleteERows()
Sheets("Sheet1").Select
Range("a2:A15000").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

for those who are intersted to remove "empty" and "blank" rows ( Ctrl + Shift + End going deep down of your worksheet ) .. here is my code.
It will find the last "real"row in each sheet and delete the remaining blank rows.
Function XLBlank()
For Each sh In ActiveWorkbook.Worksheets
sh.Activate
Cells(1, 1).Select
lRow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Range("A" & lRow + 1, Range("A1").SpecialCells(xlCellTypeLastCell).Address).Select
On Error Resume Next
Selection.EntireRow.SpecialCells(xlBlanks).EntireRow.Delete
Cells(1, 1).Select
Next
ActiveWorkbook.Save
ActiveWorkbook.Worksheets(1).Activate
End Function
Open VBA ( ALT + F11 ), Insert -> Module,
Copy past my code and launch it with F5.
Et voila :D

I have another one for the case when you want to delete only rows which are complete empty, but not single empty cells. It also works outside of Excel e.g. on accessing Excel by Access-VBA or VB6.
Public Sub DeleteEmptyRows(Sheet As Excel.Worksheet)
Dim Row As Range
Dim Index As Long
Dim Count As Long
If Sheet Is Nothing Then Exit Sub
' We are iterating across a collection where we delete elements on the way.
' So its safe to iterate from the end to the beginning to avoid index confusion.
For Index = Sheet.UsedRange.Rows.Count To 1 Step -1
Set Row = Sheet.UsedRange.Rows(Index)
' This construct is necessary because SpecialCells(xlCellTypeBlanks)
' always throws runtime errors if it doesn't find any empty cell.
Count = 0
On Error Resume Next
Count = Row.SpecialCells(xlCellTypeBlanks).Count
On Error GoTo 0
If Count = Row.Cells.Count Then Row.Delete xlUp
Next
End Sub

To make Alex K's answer slightly more dynamic you could use the code below:
Sub DeleteBlankRows()
Dim wks As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngIdx As Long, _
lngColCounter As Long
Dim blnAllBlank As Boolean
Dim UserInputSheet As String
UserInputSheet = Application.InputBox("Enter the name of the sheet which you wish to remove empty rows from")
Set wks = Worksheets(UserInputSheet)
With wks
'Now that our sheet is defined, we'll find the last row and last column
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
'Since we need to delete rows, we start from the bottom and move up
For lngIdx = lngLastRow To 1 Step -1
'Start by setting a flag to immediately stop checking
'if a cell is NOT blank and initializing the column counter
blnAllBlank = True
lngColCounter = 2
'Check cells from left to right while the flag is True
'and the we are within the farthest-right column
While blnAllBlank And lngColCounter <= lngLastCol
'If the cell is NOT blank, trip the flag and exit the loop
If .Cells(lngIdx, lngColCounter) <> "" Then
blnAllBlank = False
Else
lngColCounter = lngColCounter + 1
End If
Wend
'Delete the row if the blnBlank variable is True
If blnAllBlank Then
.rows(lngIdx).delete
End If
Next lngIdx
End With
MsgBox "Blank rows have been deleted."
End Sub
This was sourced from this website and then slightly adapted to allow the user to choose which worksheet they want to empty rows removed from.

In order to have the On Error Resume function work you must declare the workbook and worksheet values as such
On Error Resume Next
ActiveWorkbook.Worksheets("Sheet Name").Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
I had the same issue and this eliminated all the empty rows without the need to implement a For loop.

This worked great for me (you can adjust lastrow and lastcol as needed):
Sub delete_rows_blank2()
t = 1
lastrow = ActiveSheet.UsedRange.Rows.Count
lastcol = ActiveSheet.UsedRange.Columns.Count
Do Until t = lastrow
For j = 1 To lastcol
'This only checks the first column because the "Else" statement below will skip to the next row if the first column has content.
If Cells(t, j) = "" Then
j = j + 1
If j = lastcol Then
Rows(t).Delete
t = t + 1
End If
Else
'Note that doing this row skip, may prevent user from checking other columns for blanks.
t = t + 1
End If
Next
Loop
End Sub

Here is the quickest way to Delete all blank Rows ( based on one Columns )
Dim lstRow as integet, ws as worksheet
Set ws = ThisWorkbook.Sheets("NameOfSheet")
With ws
lstRow = .Cells(Rows.Count, "B").End(xlUp).Row ' Or Rows.Count "B", "C" or "A" depends
.Range("A1:E" & lstRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End with

Related

VBA If range [J:K] not empty, then copy [H:I] to the end of [J:K], else offset

I have two ranges, [H23:I32] and [J23:K50].
I need to copy values from [H23:I32] to [J23:K50] if [J23:K50] is empty, and if [J23:K50] is not empty I need to find the last row and add [H23:I32] below.
The "copy if empty" works, but the "add to the end of the list" doesn't unfortunately.
It does something, but clearly not the thing I need.
Sub Total_Loop()
Application.ScreenUpdating = False
Dim c As Range
For Each c In Range("J23:K50" & Cells(Rows.Count, "J").End(xlUp).Row)
If c.Value <> "" Then
Range("J23:K50" & Cells(Rows.Count, "J").End(xlUp).Row + 1) = Range("H23:I32")
Else: c.Value = c.Offset(, -2).Value
End If
Next
Application.ScreenUpdating = True
End Sub
Any suggestions how to fix this?
EDIT: After a lot of struggle I found a suitable solution!
Sub MoveData()
Dim lrow As Long
Dim ws As Worksheet
Set ws = Sheets("Loot")
If WorksheetFunction.CountA(ws.Range("J23:K50")) = 0 Then
ws.Range("H23:I32").Copy
ws.Range("J23").PasteSpecial xlPasteValues
Else
lrow = ws.Range("J23:K50").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ws.Range("H23:I32").Copy
ws.Range("J" & lrow + 1).PasteSpecial xlPasteValues
End If
End Sub

creating a complex macro using vba

I have a complex workbook that i need filtered using vba.
I need to delete rows that have blank cells from column G.
I then need columns C through G hidden.
Then I need Column H filtered to delete all rows greater than 2.
Finally I need Column I sorted from Largest to smallest.
This is what i have so far but It half way works and i don't want to use a command button. I want to be able to paste a document in here and the code automatically works it.
Private Sub CommandButton1_Click()
'Created by William Hinebrick 277096
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Please select range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If (xRg.Areas.Count > 1) Or (xRg.Columns.Count > 1) Then
MsgBox "You can only select one column per time", vbInformation, "Kutools for Excel"
Exit Sub
End If
xRg.Range("A1").EntireRow.Insert
Set xRg = xRg.Range("A1").Offset(-1).Resize(xRg.Rows.Count + 1)
xRg.Range("A1") = "Temp"
xRg.AutoFilter 1, ">2"
Set xRg = Application.Intersect(xRg, xRg.SpecialCells(xlCellTypeVisible))
On Error GoTo 0
If Not xRg Is Nothing Then xRg.EntireRow.Delete
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Created by William Hinebrick 277096
Dim xRg As Range
Application.ScreenUpdating = False
For Each xRg In Range("G1:G10000")
If xRg.Value = "" Then
xRg.EntireRow.Hidden = True
Else
xRg.EntireRow.Hidden = False
End If
Next xRg
Application.ScreenUpdating = True
End Sub
Sub Column_Hide()
'Created by William Hinebrick 277096
Columns("C:G").EntireColumn.Hidden = True
Columns("J").EntireColumn.Hidden = True
End Sub
Private Sub Sort_Drop(ByVal Target As Range)
On Error Resume Next
Range("I1").Sort Key1:=Range("I2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub
I would like to be able to use this daily as I will be pasting New spreadsheets to this worksheet to be filtered so I may concise the results
This should do everything listed.
If you require it to perform everytime you copy data in, then the Worksheet_Changeevent from your 2nd sub is the way to go. But this means it also runs every other time you change something in your workbook. I'd personally simply assign a Keyboard shortcut to it. Seems the easiest way to go.
Option Explicit
Sub test()
Dim i As Double
Dim lastrow As Double
lastrow = ActiveSheet.UsedRange.Rows.Count
For i = lastrow To 2 Step (-1) 'delete empty G cells
If ActiveSheet.Cells(i, 7).Value = "" Then Cells(i, 7).EntireRow.Delete
Next
lastrow = ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
For i = lastrow To 2 Step (-1) 'delete H >2
If ActiveSheet.Cells(i, 8).Value > 2 Then Cells(i, 8).EntireRow.Delete
Next
Columns("C:G").EntireColumn.Hidden = True 'hide columns
Range("I1").Sort Key1:=Range("I2"), _
Order1:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom 'Sort by I descending order
End Sub

Connect newly added Sheet to existing one

This is my first post in Stack Overflow so any mistake I make please just ignore.
So i made an button which runs the macro of an application inputbox, the name you enter in the inputbox will create a new sheet with the name you entered, it also will create a table on the new sheet. The name you put on the inputbox are the clients that newly came so i will have specific sheet with table for every client that comes.
On the other hand I got the Workers which will receive incomes from clients, I Got 4 Workers which have their own Sheet and Table of Incomes and Outcomes.
Now the question i am getting to is that, is it possible to creade a code on VBA that will say: If on the new sheet (inside the table, specificly: K8:K23, K28:K43, K49:K64) the name of the Worker is inserted, copy the name of the client and paste it into the existing sheet of the Worker.
The code i tried but did not work: (Only Check the First Sub and the end of line, the between code is just a bunch of macro for table to be created, that parts work, the problem of my code which is located at the end is that it does nothing, and yes I did an commend to the codes on purpose)
Sub KerkimiKlientit()
Dim EmriKlientit As String
Dim rng As Range, cel As Range
Dim OutPut As Integer
retry:
EmriKlientit = Application.InputBox("Shkruani Emrin e Klientit", "Kerkimi")
If Trim(EmriKlientit) <> "" Then
With Sheets("Hyrjet").Range("B10:B200")
Set rng = .Find(What:=EmriKlientit, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
sheet:
Flag = 0
Count = ActiveWorkbook.Worksheets.Count
For i = 1 To Count
WS_Name = ActiveWorkbook.Worksheets(i).Name
If WS_Name = EmriKlientit Then Flag = 1
Next i
If Flag = 1 Then
ActiveWorkbook.Sheets(EmriKlientit).Activate
Exit Sub
Else
Sheets.Add(, Sheets(Sheets.Count)).Name = EmriKlientit
Call KrijimiTabeles(EmriKlientit)
Exit Sub
End If
Else
OutPut = MsgBox("Klienti nuk u gjet", vbRetryCancel + vbInformation, "Provoni Perseri")
If (OutPut = vbRetry) Then
GoTo retry:
ElseIf (OutPut = vbCancel) Then
Exit Sub
End If
Exit Sub
End If
End With
End If
If userInputValue = "" Then
OutPut = MsgBox("Rubrika e Emrit e zbrazet", vbRetryCancel + vbExclamation, "Gabim")
If (OutPut = vbRetry) Then
GoTo retry:
ElseIf (OutPut = vbCancel) Then
Exit Sub
End If
Else
GoTo retry:
End If
End Sub
Sub KrijimiTabeles(EmriKlientit As String)
'
' KrijimiTabeles Macro
'
'This was just an middle code, it was too long so I did not paste it. Not an important part tho.
'This is the part that does not work, it just does nothing for some reason, there are multiple codes here and I tried them all.
'Sub Formula(EmriKlientit As String, ByVal Target As Range)
'ActiveWorkbook.Sheets(EmriKlientit).Activate
'If Not Application.Intersect(Range("K8:K23"), Range(Target.Adress)) Is Nothing Then
'Call Formula1
'End If
'End Sub
'Dim LR As Long, i As Long
'Application.ScreenUpdating = False
'Dim Rng As Range
'For Each Rng In Range("K8:K23")
'Select Case Rng.Value
'Case "M"
'Worksheets(EmriKlientit).Range("K2").Copy
'Worksheets("Mustafa").Range("K6").PasteSpecial Paste:=xlPasteFormulas
'End Select
'Next Rng
'Application.ScreenUpdating = True
'For Each cel In Rng
'If cel.Value = "M" Then
'Worksheets(EmriKlientit).Range("K2").Copy
'Worksheets("Mustafa").Range("K6").PasteSpecial Paste:=xlPasteFormulas
'End If
'Next cel
'ActiveWorkbook.Sheets(EmriKlientit).Activate
'If Not Application.Intersect(Range("K8:K23"), Range(Rng.Adress)) Is Nothing Then
'With Sheets(EmriKlientit)
'With .Range("K8:K23")
'If .Text = "M" Then
'Worksheets(EmriKlientit).Range("K2").Copy
'Worksheets("Mustafa").Range("K6").PasteSpecial Paste:=xlPasteFormulas
'End If
'End With
'End With
'End If
'Flag = 0
'Count = ActiveWorkbook.Worksheets.Count
'For i = 1 To Count
'WS_Name = ActiveWorkbook.Worksheets(i).Name
'If WS_Name = EmriKlientit Then Flag = 1
'Next i
'If Flag = 1 Then
'ActiveWorkbook.Sheets(EmriKlientit).Activate
'For Each Cell In Sheets(EmriKllientit).Range("K8:K23")
'If Cell.Value = "M" Then
'Range("K2").Copy
'Worksheets("Mustafa").Range("K6").PasteSpecial Paste:=xlPasteFormulas
'End If
'Next
'End If
End Sub
Thank you
I hope I was clear enough,
Any help would be appreciated.
Welcome to StackOverflow - i agree that your question can be a bit more specific...
I think what you are trying to achieve is something between this lines:
Dim wsClient As Worksheet, wsMustafa As Worksheet
Dim i As Long
Dim fRow As Long, lRow As Long
Set wsClient = ActiveWorkbook.Sheets("Client")
Set wsMustafa= ActiveWorkbook.Sheets("Mustafa")
'you can assign this through better ways, but to start with...
fRow = 8
lRow = 23
For i = fRow To lRow
If wsClient.Range("K" & i).Value = "M" Then
wsMustafa.Range("K6").Value = wsClient.Range("K" & i).Value 'or .Formula if that's what you want
End If
Next i
Hope this helps, good luck.

EXCEL VBA Code to search cell for match to a list and delete if no match

(pic link below for this example): The data starts on row "A11", one block of data is A11 to A14, I need to search that range to see if it contains a member name from a list on sheet 2, for example Erik Christensen, if the list on sheet 2 doesnt have that name I need to delete rows A11 thru A14 and continue to the next block. The list on sheet 2 will have a varying amount of members to check so that needs to be taken into consideration. Once all the rows have been processed, I need to sorth them back to start at row A11.Please see pic and I will be extremely thankful for any help.
Sheet 1
For the below answer, I have made a few assumptions:
Your data will always start on row 11 of the first sheet in the
workbook.
The search term will always be found in the second row, below
Object:...
The data will always present in rows of 4, as shown in the picture,
with End: in the 4th row.
The list of valid names is in column A (beginning on A1) of the
second sheet in the workbook.
By "sorted back to start on row A11", I assume you mean that the
remaining blocks of data should start on row A11 and continue to the
end of the data, not that any actual sorting (i.e. by name) is
required.
This code will loop through all blocks of data (beginning with the last one, since we are deleting rows). If any of the names in column A of the second sheet appear in the block of data, that block is skipped. Otherwise, if no names appear, that block is deleted.
Sub SearchAndDeleteList()
Dim i As Long
Dim j As Long
Dim LRow As Long
Dim LListRow As Long
Dim BMatch As Boolean
'Find last instance of "End:" in
LRow = Sheets(1).Range("A:A").Find(what:="End*", searchdirection:=xlPrevious).Row
'Find last non-blank row in column A of second sheet
LListRow = Sheets(2).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
If LRow >= 11 Then
'Make sure there are at least 11 rows of data
i = LRow
'MsgBox "First checkpoint: Last row of data is " & LRow 'Comment out this line
Do
BMatch = False
For j = 1 To LListRow
'Test this block to see if the value from j appears in the second row of data
If InStr(1, Sheets(1).Range("A" & i - 2).Value2, Sheets(2).Range("A" & j).Value2) > 0 Then
BMatch = True
Exit For
End If
Next j
'Application.StatusBar = "Match status for row " & i & ": " & BMatch
If Not BMatch Then
'Loop backwards to find the starting row (no lower than 11)
For j = i To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "Object:*" Then Exit For
Next j
Sheets(1).Rows(j & ":" & i).Delete
i = j - 1
Else
'Find next block
If i > 11 Then
For j = i - 1 To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "End:*" Then Exit For
Next j
i = j
Else
i = 10 'Force the loop to exit
End If
End If
'Application.StatusBar = "Moving to row " & i
Loop Until i < 11
'Loop back through and delete any blank rows
LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
'MsgBox "Second checkpoint: new last row of data is " & LRow
For i = LRow To 11 Step -1
If Sheets(1).Range("A" & i).Value2 = vbNullString Then Sheets(1).Rows(i).Delete
Next i
End If
'Application.StatusBar = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
thanks to Nick's cracking actual OP's needs, I hereby propose a solution that should be more maintainable and/or changeable as per Op's future needs
Option Explicit
Sub SearchAndDeleteList2()
Dim dataSht As Worksheet
Dim dataRng As Range, namesRng As Range, cell As Range, rangeToDelete As Range
Dim firstAddress As String
'------------------------------
' setting stuff - begin
Set dataSht = ThisWorkbook.Sheets("Sheet1Data") '<== change 'data' sheet as per your needs
With dataSht
Set dataRng = .Range("A11:A" & .Cells(.Rows.Count, 1).End(xlUp).row)
End With
If dataRng.Rows(1).row < 11 Then Exit Sub
With ThisWorkbook.Sheets("Sheet2Names") '<== change 'names' sheet as per your needs
Set namesRng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).row)
End With
Call ApplicationSet(False, False, xlCalculationManual, False)
' setting stuff - end
'------------------------------
'------------------------------
' core code - begin
Set cell = dataRng.Find("End:", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If Not MyMatch(GetName(cell.Offset(-2)), namesRng) Then Call UpdateRngToDelete(rangeToDelete, dataSht.Rows(cell.row).Offset(-3).Resize(4))
Set cell = dataRng.FindNext(cell)
Loop While cell.Address <> firstAddress
rangeToDelete.Delete
End If
' core code - end
'------------------------------
Call ApplicationSet(True, True, xlCalculationAutomatic, True)
End Sub
Function GetName(cell As Range) As String
Dim iIni As Integer
Dim iEnd As Integer
iIni = InStr(cell.value, """") '<== the 'name' is always preceeded by '"' character
iEnd = InStr(cell.value, "\") '<== the 'name' is always follwed by '/' character
GetName = Mid(cell.value, iIni + 1, iEnd - iIni - 1)
End Function
Sub UpdateRngToDelete(baseRng As Range, toBeAddedRng As Range)
If baseRng Is Nothing Then
Set baseRng = toBeAddedRng
Else
Set baseRng = Union(baseRng, toBeAddedRng)
End If
End Sub
Function MyMatch(value As String, rng As Range) As Boolean
MyMatch = Not IsError(Application.Match(value, rng, 0))
End Function
using separate functions or subs makes it easier (and faster!) to keep control and debug future code changes

Selection based on finding 2 different words in 2 columns

I would like to do the following using Excel VBA:
1) look for a certain word_1 within a column;
2) if word_1 was found in step (1), go one column to the right and look for another word which is called word_2. If word_2 was found as well, delete the entire row.
If on the other hand, word_2 was not found, the row does not have to be deleted.
The general idea is to search for multiple words in one column and if they are found, also double-check (for safety) if certain affiliated words are in column 2. Only then the entire rows should be deleted.
I made the following little example for testing:
Col1 Col2
xxx xxx
xxx xxx
xxx xxx
findme acg
xxx xxx
findme xxx
In this example I am searching for the word "findme" in column 1 and for the associated word "acg" in column 2. As you can see, row 4 would have to be deleted because both words occur in one row, as opposed to e.g. row 6, where this is not the case.
My final code:
Sub xxx()
Dim aCell As Range, bCell As Range, aSave As String
Dim fndOne As String, fndTwo As String
fndOne = "findme"
fndTwo = "acg"
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ws
Set aCell = .Columns(1).Find(What:=fndOne, LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
aSave = aCell.Address
Do
If LCase(.Cells(aCell.row, 2).Value) Like Chr(42) & fndTwo & Chr(42) Then
If bCell Is Nothing Then
Set bCell = .Range("A" & aCell.row)
Else
Set bCell = Union(bCell, .Range("A" & aCell.row))
End If
End If
Set aCell = .Columns(1).FindNext(After:=aCell)
Loop Until aCell.Address = aSave
End If
Set aCell = Nothing
If Not bCell Is Nothing Then bCell.EntireRow.Delete
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
If you used the Range.Find method and Range.FindNext method, deleting as you go and checking for matching records after each deletion, you should be able to loop through the possibilities quickly.
'delete rows as they are found
Sub delTwofers()
Dim rw As Long, n As Long, cnt As Long, rng As Range
Dim v As Long, sALLTERMs As String, vPAIRs As Variant, vTERMs As Variant
On Error GoTo bm_SafeExit
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Debug.Print Timer
sALLTERMs = "aa;bb|cc;dd|ee;ff"
With Worksheets("Sheet1") 'set this worksheet reference properly!
vPAIRs = Split(LCase(sALLTERMs), Chr(124))
For v = LBound(vPAIRs) To UBound(vPAIRs)
vTERMs = Split(vPAIRs(v), Chr(59))
cnt = Application.CountIfs(.Columns(1), Chr(42) & vTERMs(0) & Chr(42), .Columns(2), Chr(42) & vTERMs(1) & Chr(42))
rw = 1
For n = 1 To cnt
rw = .Columns(1).Find(what:=vTERMs(0), lookat:=xlPart, _
after:=.Columns(1).Cells(rw + (rw <> 1)), MatchCase:=False).Row
Do While True
If LCase(.Cells(rw, 2).Value2) Like Chr(42) & vTERMs(1) & Chr(42) Then
.Rows(rw).Delete
Exit Do
Else
rw = .Columns(1).FindNext(after:=.Cells(rw, 1)).Row
End If
Loop
Next n
Next v
End With
Debug.Print Timer
bm_SafeExit:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
'collect rows with Union, delete them all at once
Sub delTwofers2()
Dim rw As Long, n As Long, cnt As Long, rng As Range
Dim v As Long, sALLTERMs As String, vPAIRs As Variant, vTERMs As Variant
On Error GoTo bm_SafeExit
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Debug.Print Timer
sALLTERMs = "aa;bb|cc;dd|ee;ff"
With Worksheets("Sheet1") 'set this worksheet reference properly!
vPAIRs = Split(LCase(sALLTERMs), Chr(124))
For v = LBound(vPAIRs) To UBound(vPAIRs)
vTERMs = Split(vPAIRs(v), Chr(59))
cnt = Application.CountIfs(.Columns(1), Chr(42) & vTERMs(0) & Chr(42), .Columns(2), Chr(42) & vTERMs(1) & Chr(42))
rw = 1
For n = 1 To cnt
rw = .Columns(1).Find(what:=vTERMs(0), lookat:=xlPart, _
after:=.Columns(1).Cells(rw), MatchCase:=False).Row
Do While True
If LCase(.Cells(rw, 2).Value2) Like Chr(42) & vTERMs(1) & Chr(42) Then
If rng Is Nothing Then
Set rng = .Cells(rw, 1)
Else
Set rng = Union(rng, .Cells(rw, 1))
End If
Exit Do
Else
rw = .Columns(1).FindNext(after:=.Cells(rw, 1)).Row
End If
Loop
Next n
Next v
End With
Debug.Print Timer 'check timer before deleting discontiguous rows
If Not rng Is Nothing Then _
rng.EntireRow.Delete
Debug.Print Timer
bm_SafeExit:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
By first checking to make sure there is something to delete, some error control can be avoided; you only need to find the entry for the double matching criteria that you know exists.
Addendum: Deleting a collection of discontiguous rows is time consuming. The second routine (delTwofers2) above was 5% slower that the one that deleted rows as they were found. 25,000 values, 755 random deletions - 3.60 seconds for the first; 3.75 seconds for the latter.
This code applies a filter to the first two columns of the used range using your criteria. It then deletes the visible rows:
Sub DeleteSelected()
Dim RangeToFilter As Excel.Range
Set RangeToFilter = ActiveSheet.UsedRange
With RangeToFilter
.AutoFilter Field:=1, Criteria1:="find me"
.AutoFilter Field:=2, Criteria1:="access granted"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete Shift:=xlUp
End With
End Sub

Resources