What I am trying to accomplish is this:
If any cells in columns AC-AF in my entire worksheet are blank, cut the entire row and paste to a new worksheet labeled "MissingShipping".
Code should adjust with the amount of rows, since that will never be the same.
From examples I have seen I don't understand where to insert the range of the cells I want to wade through.
I get the error
"Method 'Range' of object'_Worksheet'
on the line NewSetup.Range(Cells(Destinationrow, 1), Cells(Destinationrow, lastcolumn)).Select.
Option Explicit
Sub Shipping()
Dim MissingShipping As Worksheet
Set MissingShipping = Sheets.Add(After:=Sheets(Sheets.Count))
MissingShipping.Name = "MissingShipping"
Dim NewSetup As Worksheet
Dim lastcolumn As Integer
Dim Destinationrow As Integer
Dim lastrow As Long
Set NewSetup = Worksheets("NKItemBuildInfoResults")
Set MissingShipping = Worksheets("MissingShipping")
Destinationrow = 1
lastcolumn = NewSetup.Range("XFD1").End(xlToLeft).Column
lastrow = NewSetup.Range("A1048576").End(xlUp).Row
Dim i As Long
Dim j As Long
For i = lastrow To 1 Step -1
For j = 1 To lastcolumn
If NewSetup.Cells(i, j).Value = "" Then
NewSetup.Activate
NewSetup.Range(Cells(i, 1), Cells(i, lastcolumn)).Cut
MissingShipping.Activate
NewSetup.Range(Cells(Destinationrow, 1), Cells(Destinationrow, _
lastcolumn)).Select
ActiveSheet.Paste
NewSetup.Rows(i).Delete shift:=xlUp
Destinationrow = Destinationrow + 1
Exit For
End If
Next j
Next i
End Sub
G'day Nikki,
Welcome to the world of VBA! There are plenty of great resources on the internet to help you on your journey.
It's often easier and faster to work with a range inside your code instead of reading and writing to a sheet and selecting cells to mimic things that you would normally do if you were doing the job manually.
It's a good idea to get your head around the range object early on. It's handy for working with multiple worksheets.
The following is a good start with Ranges in Excel:
https://excelmacromastery.com/excel-vba-range-cells/
Another handy thing is a collection. If you had to store a bunch of things to work with later on, you can add them to a collection then iterate over them using a "For Each" loop. This is a good explanation of collections:
https://excelmacromastery.com/excel-vba-collections/
I had a quick look at your code and using the concept of Ranges and Collections, I have altered it to do what I think you were trying to do. I had to make a few assumptions as I haven't seen you sheet. I ran the code on a bunch of random rows on my computer to make sure it works. Consider the following:
Dim MissingShipping As Worksheet
Dim NewSetup As Worksheet
Dim rangeToCheck As Range
Dim cellsToCheck As Range
Dim targetRange As Range
Dim rw As Range 'rw is a row
Dim cl As Range 'cl is a cell
Dim rowColl As New Collection
Dim i As Long
Set NewSetup = Worksheets("NKItemBuildInfoResults")
Set MissingShipping = Worksheets("MissingShipping")
'Get the range of data to check
Set rangeToCheck = NewSetup.Range("A1").CurrentRegion
'For each row in the range
For Each rw In rangeToCheck.Rows
'For the last four cells in that row
Set cellsToCheck = rw.Cells(1, 29).Resize(1, 4)
For Each cl In cellsToCheck.Cells
'If the cell is empty
If cl.Value = "" Then
'Add the row to our collection of rows
rowColl.Add rw
'Exit the for loop because we only want to add the row once.
'There may be multiple empty cells.
Exit For
End If
'Check the next cell
Next cl
Next rw
'Now we have a collection of rows that meet the requirements that you were after
'Using the size collection of rows we made, we now know the size of the range
'we need to store the values
'We can set the size of the new range using rowColl.Count
'(that's the number of rows we have)
Set targetRange = MissingShipping.Range("A1").Resize(rowColl.Count, 32)
'Use i to step through the rows of our new range
i = 1
'For each row in our collection of rows
For Each rw In rowColl
'Use i to set the correct row in our target range an make it's value
'equal to the row we're looking at
targetRange.Rows(i) = rw.Value
'Increment i for next time
i = i + 1
Next rw
End Sub
Good luck! Hope this helps.
Related
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
I have a an export "NewExport" that always randomizes the columns of data I receive. I need these columns to align with the order of columns in "TheOrder", so this code will help to re-organize the export to align with the column headers I've already built.
I have 132 columns that need re-alignment, and while I can type it all out, there must be an easier way to align with the column headers I've already created. It should be noted that the below code is shamelessly copy/pasted from another StackOverflow answer.
Sub OrderColumns(ByVal NewExport As Workbook, ByVal TheOrder As Worksheet)
Dim correctOrder() As Variant
Dim lastCol As Long
Dim headerRng As Range, cel As Range
Dim mainWS As Worksheet
Set mainWS = NewExport.Worksheets("Sheet1")
'Need to figure out how to make this an array based on a Range
correctOrder() = Array(TheOrder.Range("A1:A132").Value)
With mainWS
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set headerRng = .Range(.Cells(1, 1), .Cells(1, lastCol))
End With
Dim newWS As Worksheet
Set newWS = Ninja.Sheets.Add
newWS.Name = "Rearranged Sheet"
Dim col As Long
With newWS
For col = 1 To lastCol
For Each cel In headerRng
If cel.Value = correctOrder(col - 1) Then
mainWS.Columns(cel.Column).Copy .Columns(col)
Exit For
End If
Next cel
Next col
End With
End Sub
While it's not as automated as I would have liked (and requires one piece of hard-coding), I was able to find a solution as such:
Dim correctOrder(132) As Variant
'132 will need to be changed if there's ever any more/less columns added/excluded
For i = 1 To 132
correctOrder(i - 1) = TheOrder.Range("A" & i).Value
Next
This solution gave me the array I was looking for for use later on.
I recently wrote a 'column finder' function for a project of mine.
I've modified it to suit your requirements below.
The function requires you pass the workbook your correct ordered headings are in to capture. You could modify this to require your TargetWorksheet instead so it's a bit more dynamic.
The function returns a single dimension Array.
The function finds the last used Column in the Target Worksheet allowing for changes in the number of column headings (as mentioned in your own answer which has the column number hard coded).
Public Function CorrectOrderHeadingsArrayFunction(ByRef TargetWorkbook As Workbook) As Variant()
With TargetWorkbook.Sheets(1) 'Change this to target your correct sheet
Dim LastColumn As Long
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
CorrectOrderHeadingsArrayFunction= Application.Transpose(Application.Transpose(.Range(.Cells(1, 1), .Cells(1, LastColumn)).Value)) 'This returns the array as single dimension rather than 2D
End With
End Function
As an example, below is some sample 'Test' code to show the concept of using this function .
You could call it like so, and loop through each element perhaps comparing another arrays elements to the correct order elements and do something when the correct order value is found.
Sub TestSub()
Dim CorrectOrderArray As Variant
Dim TargetCorrectOrderElement As Variant
Dim RandomOrderArray As Variant
Dim TargetRandomOrderElement As Variant
CorrectOrderArray = CorrectOrderHeadingsArrayFunction(Workbooks("Export (4).csv")) 'Change this to target your correct workbook
RandomOrderArray = Sheet1.Range("A1:AZ1000") 'Change this to target the correct range for your data.
For Each TargetCorrectOrderElement In CorrectOrderArray
For TargetRandomOrderElement = LBound(RandomOrderArray) To UBound(RandomOrderArray)
If RandomOrderArray(TargetRandomOrderElement) = TargetCorrectorderValue Then
'Do some code to write that column to your worksheet
Exit For 'Leaves the current iteration of the random order array loop to go to the next iteration of the correct order array
End If
Next TargetRandomOrderElement
Next TargetCorrectOrderElement
End Sub
I have trouble finding examples for this specific question.
I'm automating a task in Excel and I need users to paste a list of id-numbers in an areabox. When they click ok, I need my macro to get this list in an array so I can loop trough these id's and work with them (I want to check the formats, then paste the correct once in a column in Excel)
I tried and added a RefEdit on a userform, (multiline true, scrollbars both)
I've added this to be launched when click ok:
Dim data As Variant
Dim elemnt As Variant
data = Split(Simcards.simcardsArea.Text, vbNewLine)
For Each element In data
MsgBox element
Next element
Is there a better tool for this usage? Or is this the way to go?
I need the user to be able to paste the list of id's from a copy of any program, Excel, notepad, e-mail,..
Thank you
Option Explicit
Sub TestMe()
Dim arrayRange As Range
Set arrayRange = Application.InputBox("Enter a range", "Range:", Type:=8)
Dim myArr As Variant
Dim size As Long: size = arrayRange.Rows.Count - 1
ReDim myArr(size)
Dim myCell As Range
Dim myRow As Long: myRow = 0
For myRow = 0 To size
myArr(myRow) = arrayRange.Cells(myRow + 1, 1)
Next
Dim myVal As Variant
For Each myVal In myArr
Debug.Print myVal
Next myVal
End Sub
The trick is to pay attention how the array is assigned. The idea is that the array should be as big as the size number of the rows in the selected area, hence:
Dim size As Long: size = arrayRange.Rows.Count - 1
ReDim myArr(size)
The -1 is needed, because the arrays start from 0, unless someone writes Option Base 1 on the top of our code and break anything we have hoped for.
As arrays start with a 0, it is good to loop this way:
For myRow = 0 To size
myArr(myRow) = arrayRange.Cells(myRow + 1, 1)
Next
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.
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!