Sub Delete_Rows()
'Input
'Dim tableRangeAddress_IncludingHeaderRow As String '$A$2:$G$8
'tableRangeAddress_IncludingHeaderRow = "A2:G8"
Dim tableRangeAddress_IncludingHeaderRow As String
tableRangeAddress_IncludingHeaderRow = RangeSelectionPrompt("Select the entire table range (including header row)")
If tableRangeAddress_IncludingHeaderRow = "" Then Exit Sub
Dim header_Field_RowNumber As Long
header_Field_RowNumber = Range(tableRangeAddress_IncludingHeaderRow)(1, 1).Row
Dim firstDataRow As Long
firstDataRow = header_Field_RowNumber + 1
Dim lastColumnNumber As Integer 'Last column number in original table.
lastColumnNumber = Range(tableRangeAddress_IncludingHeaderRow)(1, Range(tableRangeAddress_IncludingHeaderRow).Columns.Count).Column
Dim lastDataRow As Long 'Last row number in original table.
lastDataRow = Range(tableRangeAddress_IncludingHeaderRow)(Range(tableRangeAddress_IncludingHeaderRow).Rows.Count, 1).Row
'=SUM(IF(TRANSPOSE(ISNA(MATCH($I$2:$I$4,INDEX(FILTER(IF($A$1:$G$1=1,$A$3:$G$8,""),
'INDEX(IF($A$1:$G$1=1,$A$3:$G$8,""),MATCH(J3,$J$3:J$8,0),0)<>""),MATCH(J3,$J$3:J$8,0),0),0)))=FALSE,1,0))
Dim tableRangeAddress_ExcludingHeaderRow As String '$A$3:$G$8
tableRangeAddress_ExcludingHeaderRow = _
Range(tableRangeAddress_IncludingHeaderRow)(2, 1).Address & ":" & _
Range(tableRangeAddress_IncludingHeaderRow)(Range(tableRangeAddress_IncludingHeaderRow).Rows.Count, _
Range(tableRangeAddress_IncludingHeaderRow).Columns.Count _
).Address
Dim rowAddressWithThe_1s As String '$A$1:$G$1
rowAddressWithThe_1s = Range(tableRangeAddress_IncludingHeaderRow).Rows(1).Offset(-1, 0).Address
'Place a criteria column one column over from the last column in the original data.
'For now, just identify the column letter and place the Criteria field name, which we can just call "Criteria".
Dim columnLetter_ToPutCriteriaColumnFormula As String
columnLetter_ToPutCriteriaColumnFormula = Split(Cells(1, lastColumnNumber + 1).Address, "$")(1)
Range(columnLetter_ToPutCriteriaColumnFormula & header_Field_RowNumber).Value = "Criteria"
'Column with keywords.
Dim columnLetter_To_Retrieve_KeywordsFrom As String
columnLetter_To_Retrieve_KeywordsFrom = Split(Cells(1, lastColumnNumber + 2).Address, "$")(1)
Dim firstRowWithAKeyWord As Long '2
firstRowWithAKeyWord = Cells(1, columnLetter_To_Retrieve_KeywordsFrom).End(xlDown).Row
Dim lastRowWithAKeyWord As Long '4
lastRowWithAKeyWord = Cells(ActiveSheet.Rows.Count, columnLetter_To_Retrieve_KeywordsFrom).End(xlUp).Row
'Column letter to place the criteria field name and criteria conditional
Dim columnLetter_Of_Criteria_Range As String
columnLetter_Of_Criteria_Range = Split(Cells(1, lastColumnNumber + 3).Address, "$")(1)
'Place criteria cell (and its header).
Range(columnLetter_Of_Criteria_Range & header_Field_RowNumber - 1).Value = "Criteria"
Range(columnLetter_Of_Criteria_Range & header_Field_RowNumber).Formula = "=" & Chr(34) & ">0" & Chr(34)
'Define this address for the Advanced Filter (for later)
Dim criteriaRangeAddress As String
criteriaRangeAddress = columnLetter_Of_Criteria_Range & header_Field_RowNumber - 1 & ":" & columnLetter_Of_Criteria_Range & header_Field_RowNumber
'Column letter to place row counter. For compactness, just put in the same column as the criteria range.
Dim columnLetter_ToPutRowCounterFormula As String
columnLetter_ToPutRowCounterFormula = columnLetter_Of_Criteria_Range
'Fill the criteria column.
With Range(columnLetter_ToPutCriteriaColumnFormula & firstDataRow & ":" & columnLetter_ToPutCriteriaColumnFormula & lastDataRow)
.Formula = "=SUM(IF(TRANSPOSE(ISNA(MATCH(" & "$" & columnLetter_To_Retrieve_KeywordsFrom & "$" & firstRowWithAKeyWord & ":" & "$" & columnLetter_To_Retrieve_KeywordsFrom & "$" & lastRowWithAKeyWord & ",INDEX(FILTER(IF(" & rowAddressWithThe_1s & "=1," & tableRangeAddress_ExcludingHeaderRow & "," & Chr(34) & Chr(34) & "),INDEX(IF(" & rowAddressWithThe_1s & "=1," & tableRangeAddress_ExcludingHeaderRow & "," & Chr(34) & Chr(34) & "),MATCH(" & columnLetter_ToPutRowCounterFormula & firstDataRow & "," & "$" & columnLetter_ToPutRowCounterFormula & "$" & firstDataRow & ":" & columnLetter_ToPutRowCounterFormula & "$" & lastDataRow & ",0),0)<>" & Chr(34) & Chr(34) & "),MATCH(" & columnLetter_ToPutRowCounterFormula & firstDataRow & "," & "$" & columnLetter_ToPutRowCounterFormula & "$" & firstDataRow & ":" & columnLetter_ToPutRowCounterFormula & "$" & lastDataRow & ",0),0),0)))=FALSE,1,0))"
.Replace What:="@", Replacement:="", LookAt:=xlPart, FormulaVersion:=xlReplaceFormula2
End With
'Fill the row counter column.
Range(columnLetter_ToPutRowCounterFormula & firstDataRow & ":" & columnLetter_ToPutRowCounterFormula & lastDataRow).Formula = "=ROW()"
'Append a column letter to the original table range address.
Dim firstColumnLetter_Of_OriginalTableAddress As String
firstColumnLetter_Of_OriginalTableAddress = Split(Range(tableRangeAddress_IncludingHeaderRow)(1, 1).Address, "$")(1)
tableRangeAddress_IncludingHeaderRow = firstColumnLetter_Of_OriginalTableAddress & header_Field_RowNumber & ":" & columnLetter_ToPutCriteriaColumnFormula & lastDataRow
'Copy to range
Dim topLeft_CellAddress_ToPaste As String 'Make it paste in the same start row, 5 columns to the right.
topLeft_CellAddress_ToPaste = Range(Split(Cells(header_Field_RowNumber, lastColumnNumber + 5).Address, "$")(1) & header_Field_RowNumber).Address
Dim columnLetterOfPastedResult_Where_Criteria_Column_Is As String
columnLetterOfPastedResult_Where_Criteria_Column_Is = Split(Cells(header_Field_RowNumber, lastColumnNumber + Range(topLeft_CellAddress_ToPaste).Column).Address, "$")(1)
'Clear the contents in that rectangular portion of the sheet ONLY.
Range(topLeft_CellAddress_ToPaste & ":" & columnLetterOfPastedResult_Where_Criteria_Column_Is & lastDataRow).ClearContents
'Advanced filter
Range(tableRangeAddress_IncludingHeaderRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Range(criteriaRangeAddress), _
CopyToRange:=Range(topLeft_CellAddress_ToPaste), _
Unique:=False
'Delete all helper column values/formulas.
Range(columnLetter_ToPutCriteriaColumnFormula & firstDataRow - 1 & ":" & columnLetter_ToPutCriteriaColumnFormula & lastDataRow).ClearContents
Range(columnLetter_ToPutRowCounterFormula & firstDataRow - 2 & ":" & columnLetter_ToPutRowCounterFormula & lastDataRow).ClearContents
Range(columnLetterOfPastedResult_Where_Criteria_Column_Is & firstDataRow - 1 & ":" & columnLetterOfPastedResult_Where_Criteria_Column_Is & lastDataRow).ClearContents
End Sub
Sub Test__RangeSelectionPrompt()
MsgBox RangeSelectionPrompt("Choose Cells")
End Sub
Function RangeSelectionPrompt(titleOfRangeSelectionPromptBox As String)
'Code is from http://www.vbaexpress.com/forum/showthread.php?763-Solved-Inputbox-Cell-Range-selection-Nothing-selected-or-Cancel&p=6680&viewfull=1#post6680
Dim Selectedarea As Range
On Error Resume Next
Set Selectedarea = Application.InputBox(prompt:="Left click on the top-left cell and drag to the botSomething-right cell.", _
Title:=titleOfRangeSelectionPromptBox, Default:=Selection.Address, Type:=8)
'If the user clicked on cancel,
If Selectedarea Is Nothing Then
Selectedarea = ""
Exit Function
End If
RangeSelectionPrompt = Selectedarea.Address
End Function
