Excel VBA find/replace loop - really new at VBA - loops

I need to add a section within an existing macro that takes a cell's address and looks for that address (as a string?) from the values within a range of cells elsewhere on the sheet - then offsets one column over to use that cell's value to replace the original value of the cell who's address was searched.
My code is looking for unmerged cells, and when it finds an unmerged cell, it needs to grab the correct value to put in there. Not all cells in my range mCell are unmerged, so this is a find/replace within a loop.
I cannot hard code the cells, and also cannot figure out a functional loop that successfully moves through my range and finds/replaces using values from another part of the worksheet. I'm new at VBA and keep getting errors and wind up defining a dozen ranges and strings trying to carry over the data. Any help would be greatly appreciated!
For example:
if unmerged mCell.address = "B20", then the macro finds the value "B20" in a designated range (in example below, was found in cell Q20), then offset one column over (to cell R20), then uses value of that cell (which is 6) to replace the value of mcell, such that the new cell value of B20 (i.e., the active mCell) = 6. Then on to the next unmerged mCell...
row Column Q Col. R '(not code, but can't get formatting any other way)
18 B18(text) 5
19 B19 4
20 B20 6
21 B21 3
Thank you for any suggestions, My existing code works great until "Part II", but then I'm failing miserably and am requesting specific help on how to correct/improve the code. Existing code is:
' This sub looks for the word "Table" in column A. If the word appears, it unmerges the cells in columns B - E
' and the rows following to allow for the insert of a table, then merges all other rows for sake of format.
Option Explicit
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Range("B14:E64").SpecialCells(xlCellTypeVisible).Select
With Selection
.RowHeight = 17
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
.WrapText = True
End With
'*******Merge or unmerge rows according to whether or not they contain Table data -
' this only acts on visible cells, so rows of data table can be hidden as needed
Dim TA As Integer
Dim ColValues As Variant
Dim rng As Range
Dim tabNo As Range 'uses value on worksheet to know how many rows to unmerge
'*******Dims in finding and replacing unmerged cell values
Dim mergeRange As Range 'Range B16:E64 - where my mCells are being pulled from
Dim mCell As Range 'Cell that is unmerged, looking for its address
Dim ws As Worksheet
Dim tabledata As Range 'Range Q11:Q38 - this is the column I'm searching in and offsetting from
Dim aCell As String 'picks up cell address, to use in .find
Dim myCell As Range 'cell address in Q
Dim ReplaceString As String
Dim foundCell As Range
Dim bCell As Range
Dim i As Long
Application.DisplayAlerts = False
'Make column B = Column A values, cannot make this happen on sheet, because data is too variable
ColValues = ActiveSheet.Range("A16:A64").Value
ActiveSheet.Range("B16:B64").Value = ColValues
'Look for data table, if not present, merge cells
Set rng = ActiveSheet.Range("B14:B100")
Set tabNo = ActiveSheet.Range("K6")
For TA = 15 To 64 'defines TA variable to loop from row 14 to row 64
If Cells(TA, "A") = "Table" Then '
Range("B" & TA & ":E" & TA + tabNo).UnMerge 'unmerges the row with "Table" listed and the next 7 rows (to make a 8-row x 4 column unmerged area for table
TA = TA + tabNo ' moves active cell "TA" down 7 spaces
Else
Range("B" & TA & ":E" & TA).Merge 'If "Table" not found, then merge the cells for the row TA is in across columns B:E
End If
Next TA
'*** Part II: Need some calculation to loop or offset or find through data and fill
'unmerged cells from a data table on the worksheet.
'the placement of the data table varies depending on the layout of the report,
'which changes day to day, so can not be hard coded into the cells - needs to look up
'position of the word "Table" and dump data after that.
'offset? .find? loop?
'***want to take the cell address of each unmerged cell within the range of the report
'and look for that cell in an array, then replace the cell contents with the correct value
Set mergeRange = ActiveSheet.Range("B16:E64")
For Each mCell In mergeRange
' If mergeRange.MergeCells = True Then
' MsgBox "all cells are merged, exiting sub"
' Exit Sub
'Else
If mCell.MergeCells = False Then
aCell = mCell.Address '??? Need to set the cell address as
'a text string or something in order to look for that address in the values
'of cells in range "tabledata"
'MsgBox "aCell " & Range(aCell).Address
Set tabledata = ActiveSheet.Range("Q11:Q38")
Set bCell = tabledata.Find(aCell, After:=Range("Q1"), LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'this gives me a "type mismatch" error that I cannot clear
'- then wanting the value of the cell offset one column over
'need to take the value of that offset cell and use it
'to replace the value of the original unmerged cell (mCell)
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
Next mCell
End Sub

There were a few problems in there but I think it's working now. You'll have to verify as I'm still not 100% sure what it is supposed to do.
Problem 1: You don't need tabledata. You specify in the search parameters After:=Range("Q1") so it's looking in the right place. Find works on a Cells so your line should be:
Set bCell = Cells.Find(aCell, After:=Range("Q1"), LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Problem 2: Your line aCell = mCell.Address needs to be aCell = Replace(mCell.Address, "$", "") as it comes in as an absolute cell reference and the cell address on your sheet are not (probably a more elegant way of doing this).
There were a couple of other problems in your Dropbox file but those should be sorted too now. There was an extra Next and the line aCell.Offset(, 1) = bCell.Offset(, 1) seems like it should be mCell.Offset(, 1) = bCell.Offset(, 1).
https://www.dropbox.com/s/jqdg3v0gd59mxjn/Test%20Workbook%201016jb.xlsm

Related

Array loses value when a vba opened workbook it was read from closes

I want to use some data stored in a VBA defined array which I read in from another workbook. I process the data in it's original workbook to remove all spaces, read the data in, and close the original workbook without saving. Then when I call another sub I find the array, and range variables I extracted from that workbook are no longer defined. Is it possible to make the values stick without keeping the workbook open? The problem is near the end of the routine, and noted in caps.
THANKS!
All subroutines that are called work properly except the last one, which is still being defined.
I will share the other routines if needed or someone thinks it will solve a problem for them --DONE. There is no error checking in any of them as of yet!
Sub UpdateEmployeewithholding()
'This sub will clean employee withholding as it is exported from QuickBooks and then read the file into this workbook
'The path is already stored in the names manager
'This routine needs to integrate the existing subs "changevalueofname" and "getpath". They should update before executing the balance of this routine
Dim MyWorkBook As Workbook
Dim MyPath As Variant 'Contains path to employee withholding spreadsheet as exported from quickbooks. This sheet is to be modified for reading, but not saved
Dim MyRange As Range 'Contains a defined range after setting it so
Dim whichrow As Variant 'Marks the starting point for routines that find and delete blanks as well as those that define range values and scan them into an array
Dim Direction As Variant 'Defines whether we are progressing over "Rows" or "Columns"
Dim ArrayWidth As Range 'Holds the top row addresses of the array
Dim ArrayHeight As Range 'Holds the left column addresses of the array
Dim MyArray As Variant 'Holds the array to transfer to this spreadsheet
whichrow = 1 'We are starting in cell A1 or R1C1
Direction = "Rows"
'******************************************************************************************************
'***INSERT Code that will read the string value stored in the name manager Name "PathToEmployeeWithholding" into the variable "MyPath"
' and eliminate the hard coded path from the routine
' STILL MISSING
'*****************************************************************************************************
'Setting MyPath to the fixed path to employee withholding until we can get the routine to open the workbook from a varialbe
'stored in the name manager
MyPath = "D:\redacted\Employee Withholding .xlsx"
'ActiveWorkbook.Names (PathToEmployeeWithholding)
Debug.Print MyPath
Set MyWorkBook = Workbooks.Open(MyPath)
Debug.Print ActiveWorkbook.Name
With MyWorkBook
.Activate
Call FindDataRange(MyRange, whichrow, Direction)
Debug.Print MyRange.Address
Call DeleteBlanks(MyRange, Direction)
'Use ArrayWidth and ArrayHeight with the routine FindDataRange
'to get the width and height of the final arrray that will be read into the spreadsheet
'close without saving the data, so it will be preserved as it came from quickbooks
Call FindDataRange(ArrayWidth, whichrow, Direction)
Direction = "Columns)"
Call FindDataRange(ArrayHeight, whichrow, Direction)
Debug.Print "Array Width " & ArrayWidth.Address
Debug.Print "array height " & ArrayHeight.Address
'Insert a call to a routine that will copy an array consisting of myrange as the top plus all the rows under it, which include employee info
Call ReadArray(MyArray, ArrayWidth, ArrayHeight)
'Insert code to test employee sheets and recap sheet, as well as sheet containing lookup data.
'As that code determines what the current structure is, it should update the structure to conform to the imported array
'If no data exists in the spreadsheet, then we create pages for each new employee, and write the Recap and the Lookup Table
'If data already exists in the spreadsheet, then we maintain the existing employees. and append their sheets,
'and add new Data to the lookup table, (Questionable whether we should totally rewrite the lookup table or just append
'the new data and sort by employee name to maintain old employee data)
'and rewrite the Recap so the user only has to enter time for current employees
'NOTE the employee sheets will be labeled by their name, just as listed in the lookup table
.Close (False)
End With
ResetMessage = MsgBox("You are about to reset the spreadsheet to match the data that was just loaded. Continue?", vbOKCancel)
If ResetMessage = 2 Then
Exit Sub
End If
Call ResetWorksheets(MyArray, ArrayWidth, ArrayHeight) '**ALL OF THESE VARIBALES LOSE VALUE WHEN MY WORKBOOK CLOSES**
End Sub
Sub FindDataRange(MyRange As Range, whichrow As Variant, Direction As Variant)
'This routine will return a single row or Column range of data
'that includes the first cell in whichrow to the last cell with data in whichrow
Dim StartRange As Range
Dim FullRange As Range
If Direction = "Rows" Then
'Startrange will be first cell in whichrow
Set StartRange = Cells(whichrow, 1)
'Fullrange will be the entire row of whichrow
Set FullRange = Range(StartRange, StartRange.Offset(0, Columns.Count - 1)) 'this produced the entire whichrow row as the range.
Set MyRange = Range(StartRange, FullRange.Find("*", StartRange, xlValues, xlPart, xlByRows, xlPrevious, True)) 'startrange,xlvalues,xlpart,xlbyrows,xlPrevious,true)
'this should return the range which has the data
Debug.Print MyRange.Address
Else
'Startrange will be first cell in whichrow
Set StartRange = Cells(1, whichrow)
'Fullrange will be the entire column of whichrow
Set FullRange = Range(StartRange, StartRange.Offset(Rows.Count - 1, 0)) 'this produced the entire whichrow column as the range.
Set MyRange = Range(StartRange, FullRange.Find("*", StartRange, xlValues, xlPart, xlByColumns, xlPrevious, True)) 'startrange,xlvalues,xlpart,xlbyrows,xlPrevious,true)
'this should return the range which has the data
Debug.Print MyRange.Address
End If
End Sub
Sub DeleteBlanks(WorkingRange As Range, Direction As Variant)
'This will delete the entire row/column of blanks according to the cell in a single row/column contents
'To use it we need to input a working range that is to be considered to delete blanks from, and a direction which is either "Rows" or "Columns"
Dim Message As String
For i = WorkingRange.Cells.Count To 1 Step -1
Debug.Print Direction
Select Case Direction
Case Is = "Rows"
If WorkingRange.Cells(i) = "" Then
Debug.Print WorkingRange.Cells(i).Address
WorkingRange.Cells(i).EntireColumn.Delete
End If
Case Is = "Columns"
If WorkingRange.Cells(i) = "" Then
WorkingRange.Cells(i).EntireRow.Delete
Debug.Print WorkingRange.Cells(i).Address
End If
Case Else
Message = "You must declare a direction either Rows or Columns to search before calling this routine"
MsgBox Message, vbOKOnly, "Routine Requires a Direction"
End Select
Next
End Sub
Sub ReadArray(MyArray As Variant, ArrayWidth As Range, ArrayHeight As Range)
'This routine should read an array with a width contained in the ArrayWidth range, and a height
'contained in the ArrayHeight range. We retreive the actual size to read by using range.cells.count
Dim WidthStep As Long 'Contains the width of the array
Dim HeightStep As Long 'Contains the height of the array
Dim i As Long 'step counter for height becaue it has to be the outside loop to read in rows
Dim j As Long 'step counter for width because it has to be the inside loop to read in rows
WidthStep = ArrayWidth.Cells.Count
HeightStep = ArrayHeight.Cells.Count
ReDim MyArray(HeightStep, WidthStep)
' Let's read the array in in rows, but remember the employee names are in the left column
For i = 1 To HeightStep
For j = 1 To WidthStep
MyArray(i, j) = ArrayWidth.Cells(i, j).Value
Debug.Print MyArray(i, j)
Next j
'!!!!!!!!This routine READS LEFT TO RIGHT FIRST AND THEN TOP TO BOTTOM
'Writing must consider how it is reading to get things in the correct place
Next i
End Sub
Sub ResetWorksheets(MyArray As Variant, ArrayWidth As Range, ArrayHeight As Range)
'Currently a blank subroutine with a test to verify data transfered
For i = 1 To ArrayHeight.Cells.Count
Debug.Print MyArray(1, i).Value
Next i
End Sub
It begs further testing, but I think I figured out the problem. The data is still in the array after closing, but I have a reference to two ranges in the closed spreadsheet, which loose their cells.count value when the spreadsheet closes. If it tests out, then transferring the width and height to long variables should preserve the data.
I also had a problem with the reset worksheet subroutine, which was trying to call a .value from the array I was stepping through. (MyArray(i,j).value which was throwing an error as well.
Verified that solved the problem.
Now on to get it to open the file it reads from using a name programmatically stored in the name manager. I have code in there and blocked off that did not work, which was temporarily replaced with a static statement to get the file open so I could continue.
Thanks!
'lines so marked below were Added
Dim Width As Long 'Added Holds the array width to prevent loosing it when the original spreadsheet closes
Dim Height As Long 'Added Holds the array height to prevent loosing it when the original spreadsheet closes
Call FindDataRange(ArrayWidth, whichrow, Direction)
Width = ArrayWidth.Cells.Count 'Added
Direction = "Columns)"
Call FindDataRange(ArrayHeight, whichrow, Direction)
Debug.Print "Array Width " & ArrayWidth.Address
Debug.Print "array height " & ArrayHeight.Address
Height = ArrayHeight.Cells.Count 'Added
'Lines below were modifid to incorperate the two added variables
Sub ResetWorksheets(MyArray As Variant, Width As Long, Height As Long) 'modified
Dim CurrentWorkBook As Workbook
''Set CurrentWorkBook = ActiveWorkbook 'Save the current workbook which is the one exported from Quick Books
''ThisWorkbook.Activate 'This workbook is the one the code is in. It is also the one we need to update or create pages for
'We need to first test and see what exists in the workbook according to ranges
For j = 1 To Width 'modified
For i = 1 To Height 'modified
Debug.Print MyArray(i, j)
Next i
Next j
'CurrentWorkBook.Activate 'Restore the CurrentWorkBook to active status before returning and closing the book This should be the very 'last operation in the routine
End Sub

Looping through rows, copy cell and then move back to the original sheet in a new loop

I have been trying to put together the code for the following request, I am not an expert and I really need help on this, thanks in advance:
There are 2 sheets 1 "Database", 2 "Scorecard".
Loop through the rows in column C Database Sheet, each single value
will be copied into the Scorecard sheet Cell B3, this will change the
value of the cell C30.
The new value for cell C30 will then need to be copied back to the Database Sheet in new column "F", and this will be looped till the
last cell. Filling the list.
It requires to be correspondent to the the cell, thus the first value in C2 will need the matching value in F2 and so on.
The database will change in time so it requires a code that allows to consider new entrances.
I have tried to modify this code I've seen in a different question: Loops in VBA? I want to use a loop to select and copy till last cell but can't make it work...
Thanks so so much!
Sub LoopThroughColumnC()
Dim LastRowInColC As Long, Counter As Long
Dim SourceCell As Range, DestCell As Range
Dim MySheet As Worksheet
'set references up-front
Set MySheet = ThisWorkbook.Worksheets("Dati per calcolo")
Set CopySheet = ThisWorkbook.Worksheets("Scheda costo tessuto e capo")
With MySheet
LastRowInColC = .Range("C" & .Rows.Count).End(xlUp).Row
Set DestCell = ThisWorkbook.Worksheets("Scheda costo tessuto e capo").Range("B3")
End With
'loop through column C, copying from cells(counter, 11) to B3
With MySheet
For Counter = 1 To LastRowInColC
Set SourceCell = .Range("C" & Counter)
SourceCell.Copy Destination:=DestCell
If Target.Address = Range("A1").Address Then
' Get the last row on our destination sheet (using Sheet2, col A here)...
Dim intLastRow As Long
intLastRow = Sheet2.Cells(Sheet2.Rows.Count, "B").End(xlUp).Row
' Add our value to the next row...
Sheet2.Cells(intLastRow + 1, "A") = Target.Value
End If
Next Counter
End With
End Sub

Filter column based on array from another sheet

I have three sheets called: "Dane magazyn", "Sheet3" and "Dostawcy".
What I want my Excel to do is:
1) filter out #N/A values in col. J on sheet "Dane magazyn". All values that should stay after filtering are stored in Col. E on sheet "Dostawcy" - 21 entries, but it will be more in the future.
2) select data that remained after filtering and copy to "Sheet3"
Here's my code so far:
Sub filtruj()
Dim i As Long, arr As Variant, LastRow As Long
Sheets("Dostawcy").Select
With ActiveSheet
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
End With
arr = Sheets("Dostawcy").Range("E2:E" & LastRow).Value
Sheets("Dane magazyn").Select
With ActiveSheet
**.Columns("J").AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues** <---- here I get error
End With
Rest of code...
Error message I get is:
"Run-time error '1004':
AutoFilter method of Range class failed"
websites I've checked (not all listed)
Using string array as criteria in VBA autofilter
VBA assign a range to an Array from different sheet
Fastest way to read a column of numbers into an array
Thanks in advance
Here is working code:
Dim rng, rngToFilter As Range
Dim i As Integer: i = 1
'set you range to area with values to compare against
'if you can, specify here exact range instead of whole column, it can increase efficiency
Set rng = Sheets("Dostawcy").Range("E:E")
'set range to be filtered out, don't specify here whole column,
'in following loop it can result in overflow error
Set rngToFilter = Sheets("Dane magazyn").Range("J1:J100")
'here we will iterate through all cells within the searched range,
'for every cell we will try to find it's value within the other range,
'if it succeeds, so it's not Nothing, then we copy it to Sheet3
For Each cell In rngToFilter
'if any cell causes the error, we will skip one iteration
On Error GoTo ErrorHandler:
If Not rng.Find(cell.Value) Is Nothing Then
Sheets("Sheet3").Cells(i, 1).Value = cell.Value
i = i + 1
End If
ErrorHandler:
Next cell
Don't use Select unless you must, it reduces efficiency of a program.

VBA - looping through cells using "i"

I am trying to loop through a range on cells in a column and then check if the cell is empty, if it is, I want to copy the corresponding row into a new sheet. This is what I have so far:
If Len(Cells(i, 17)) = 0 Then
Sheets("GES1").Activate
ActiveSheet.Range(Cells(i, 1), Cells(i, 17)).Select
Selection.Copy
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Paste
End If
Next i
The problem with this code is that as soon as there is an empty cell the corresponding row gets copied and pasted into a new sheet and the following rows also get copied and pasted into new sheets even if their corresponding cells are not blank. I want the code to copy and paste any row corresponding to an empty cell value in column Q i.e 17 to a single new sheet
Problem is with this line. Try correcting it.
Worksheets.Add after:=Sheets(Sheets.Count)
I believe that you want all of the rows with a blank column Q cell to be copied to a single new worksheet.
Sub copy_blank_to_new()
Dim i As Long, ws As Worksheet
Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
With Sheets("GES1")
.Cells(1, 1).Resize(1, 17).Copy Destination:=ws.Cells(1, 1)
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If Not CBool(Len(Cells(i, 17).Value)) Then _
.Cells(i, 1).Resize(1, 17).Copy _
Destination:=ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next i
End With
Set ws = Nothing
End Sub
That starts by copying the first row across. I've guessed that is column header label information. It then copies each row with a blank (actually zero-length value) into subsequent rows in the same new worksheet.
If column Q could be blank then there is the distinct possibility that other columns could contain blanks. I've used column A to determine the extents of the data to be examined. If this is insufficient, there are other methods but having some idea of what your data actually looks like would help.

Excel clear cells based on contents of a list in another sheet

I have an excel Sheet1 of a thousand of rows and 20 columns from A1 to T1. Each cell in that range has some data in it, usually one or two words.
In Sheet2, A1 column I have a list of data of 1000 values.
I am working on VBA script to find words from Sheet2 list in Sheet1 and clear the values of the cells of the found ones.
I now have a VBA script that works only on A1 column of Sheet1 and it deletes the rows only. Here's the script:
Sub DeleteEmails()
Dim rList As Range
Dim rCrit As Range
With Worksheets("Sheet1")
.Range("A1").Insert shift:=xlDown: .Range("A1").Value = "Temp Header"
Set rList = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
End With
With Worksheets("Sheet2")
.Range("A1").Insert shift:=xlDown: .Range("A1").Value = "Temp Header"
Set rCrit = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
End With
rList.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
rList.Offset(1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
Worksheets("Sheet1").ShowAllData
rList(1).Delete shift:=xlUp: rCrit(1).Delete shift:=xlUp
Set rList = Nothing: Set rCrit = Nothing
End Sub
Could anyone help me? I need the values cleared, not rows deleted, and this should work on all columns of Sheet1, not just A1.
Here is another method using an array by minimizing the traffic between sheet (iteration via range/cells) and code. This code doesn't use any clear contents. Simply take the whole range into an array, clean it up and input what you need :) with a click of a button.
edited as per OP's request: adding comments and changing the code for his desired sheets.
Code:
Option Explicit
Sub matchAndClear()
Dim ws As Worksheet
Dim arrKeys As Variant, arrData As Variant
Dim i As Integer, j As Integer, k As Integer
'-- here we take keys column from Sheet 1 into a 1D array
arrKeys = WorksheetFunction.Transpose(Sheets(1).Range("A2:A11").Value)
'-- here we take to be cleaned-up-range from Sheet 2 into a 2D array
arrData = WorksheetFunction.Transpose(Sheets(2).Range("C2:D6").Value)
'-- here we iterate through each key in keys array searching it in
'-- to-be-cleaned-up array
For i = LBound(arrKeys) To UBound(arrKeys)
For j = LBound(arrData, 2) To UBound(arrData, 2)
'-- when there's a match we clear up that element
If UCase(Trim(arrData(1, j))) = UCase(Trim(arrKeys(i))) Then
arrData(1, j) = " "
End If
'-- when there's a match we clear up that element
If UCase(Trim(arrData(2, j))) = UCase(Trim(arrKeys(i))) Then
arrData(2, j) = " "
End If
Next j
Next i
'-- replace old data with new data in the sheet 2 :)
Sheets(2).Range("C2").Offset(0, 0).Resize(UBound(arrData, 2), _
UBound(arrData)) = Application.Transpose(arrData)
End Sub
Please not that you what you really need to set here are the ranges:
Keys range
To-Be-Cleaned up range
Output: (for displaying purpose I am using the same sheet, but you can change the sheet names as you desire.
Edit based on OP's request for running OP's file:
The reason that it didn't clean all your columns is that in the above sample is only cleaning two columns where as you have 16 columns. So you need to add another for loop to iterate through it. Not much performance down, but a little ;) Following is a screenshot after running your the sheet you sent. There is nothing to change except that.
Code:
'-- here we iterate through each key in keys array searching it in
'-- to-be-cleaned-up array
For i = LBound(arrKeys) To UBound(arrKeys)
For j = LBound(arrData, 2) To UBound(arrData, 2)
For k = LBound(arrData) To UBound(arrData)
'-- when there's a match we clear up that element
If UCase(Trim(arrData(k, j))) = UCase(Trim(arrKeys(i))) Then
arrData(k, j) = " "
End If
Next k
Next j
Next i
I don't have excel to hand right now so this may not be exactly 100% accurate on formulae name but I believe this line needs to change:
rList.Offset(1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
to
rList.Offset(1).ClearContents
once you've set rList to your desired selection. Delete is the reason you're deleting rows and not clearing them. (1) is the reason you were doing A1 only instead of entire range.
EDIT
The final code that I tested this with was (includes going over all columns now):
Option Explicit
Sub DeleteEmails()
Dim rList As Range
Dim rCrit As Range
Dim rCells As Range
Dim i As Integer
With Worksheets("Sheet2")
.Range("A1").Insert shift:=xlDown
.Range("A1").Value = "Temp Header"
Set rCrit = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
End With
Set rCells = Sheet1.Range("$A$1:$T$1")
rCells.Insert shift:=xlDown
Set rCells = rCells.Offset(-1)
rCells.Value = "Temp Header"
For i = 1 To rCells.Count
Set rList = Sheet1.Range(rCells(1, i).address, Sheet1.Cells(Rows.Count, i).End(xlUp))
If rList.Count > 1 Then 'if a column is empty as is in my test case, continue to next column
rList.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
rList.Offset(1).ClearContents
Worksheets("Sheet1").ShowAllData
End If
Next i
rCells.Delete shift:=xlUp
rCrit(1).Delete shift:=xlUp
Set rList = Nothing: Set rCrit = Nothing
End Sub
PS: may I request that you do not use ':' in vba. Its really hard to notice in vba's default IDE and took me a while to figure why things were happening but not making sense!

Resources