I'm trying to to run a command if these arguments checks , but it's giving me incompatibily type on that block, what am I doing wrong?
Dim rn as range
For Each rg In Columns("X")
If rg.Value Like "?*#?*.?*" And _
LCase(Cells(rg.Row, "U").Value) = "Demande de création d'intervention" _
And LCase(Cells(rg.Row, "V").Value) <> "envoyé" Then
Comparing Strings
If you loop through the cells of the whole column, it will take forever. Calculate the last row, the row of the last non-empty cell in the column, instead.
LCase(Something) will never be equal to Demande.... Use demande... instead.
If you use CStr to convert a value to a string, you won't have to worry about the value being incompatible when comparing it to another string.
The Code
Option Explicit
Sub Test()
Const FirstRow As Long = 2
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "X").End(xlUp).Row
' If LastRow < FirstRow Then
' MsgBox "No data in column.", vbCritical
' Exit Sub
' End If
' Reference the column range ('rg').
Dim rg As Range
Set rg = ws.Range(ws.Cells(FirstRow, "X"), ws.Cells(LastRow, "X"))
' Reference the other column ranges ('rg2', 'rg3')
Dim rg2 As Range: Set rg2 = rg.EntireRow.Columns("U")
Dim rg3 As Range: Set rg3 = rg.EntireRow.Columns("V")
' Note that all three ranges are of the same size.
' Declare additional variables to be use in the loop.
Dim Cell As Range ' Current cell in the first range
Dim cString As String ' String Representation of the Current Cell's Value
Dim r As Long ' Index of the Current Cell
' Use 'CStr' to convert the values to strings to avoid an error occurring
' if the cell contains an error value.
For Each Cell In rg.Cells ' note '.Cells'
r = r + 1 ' count the cells (in this case rows)
cString = CStr(Cell.Value)
If cString Like "?*#?*.?*" _
And LCase(CStr(rg2.Cells(r).Value)) _
= "demande de création d'intervention" _
And LCase(CStr(rg3.Cells(r).Value)) <> "envoyé" Then
' Do your thing, e.g.
Debug.Print r, cString
End If
Next Cell
End Sub
Results in the Immediate window (Ctrl+G).
8 FY#I.NV
11 MF#X.UT
14 EU#X.IF
Related
I'm trying to check a range of cells for the value "X" and when the column name where the "X" was found is among an array I have previously specified, I want to have a helper column that would say TRUE otherwise say FALSE.
To illustrate, here's a sample table:
In my sample, I have this array that contains 3 values ( Math, English and History). If there is an X in any of the rows whose header name is in the array, I want the helper column to say TRUE otherwise FALSE. It doesn't have to be all of the values in the array, it can be at least only one.
Here is my code (my original file has more columns than my sample, so my code is liek this)
Sub add_helper()
' Adding helper column
Dim checking As Variant
checking = check_issue() -- this is another function, basically checking will contain the values I want to check in this case Math, English and History, i have confirmed this gets it successfully
Dim wks As Worksheet
Set wks = ActiveSheet
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "I").End(xlUp).row
Set rowRange = wks.Range("I2:AD" & LastRow)
Set colRange = wks.Range("I1:AD1")
'Loop through each row
For Each rrow In rowRange
Do
For Each cell In colRange
'Do something to each cell
If InStr(checking, cell.value) > 0 Then
If Cells(rrow.row, rrow.Column).value <> "" Then
wks.Range("AI" & rrow.row).value = "TRUE"
Exit For
Else
wks.Range("AI" & rrow.row).value = "FALSE"
End If
End If
Next cell
Loop Until wks.Range("AI" & rrow.row).value <> "TRUE"
Next rrow
End Sub
My code results to just having an input of true whenever there is an X without actually checking if the header column is in my array.
Did you try normal formulas in Excel? You could create a table (a ListObject) with the courses as your array values and the combine SUMPRODUCT with COUNTIF to output True/False in your helper column. Easy to update and adapt:
Notice the table at most right named T_COURSES. The formula in helper column is:
=SUMPRODUCT(--(COUNTIF(T_COURSES,$B$1:$E$1)>0)*--(B2:E2="x"))>0
It works perfectly and it autoupdates changing values:
Match Headers of Matches Against Values in Array
Option Explicit
Sub AddHelper()
Dim checking As Variant: checking = check_issue()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim hrg As Range: Set hrg = ws.Range("I1:AD1") ' Header Range
Dim drg As Range ' Data Range
Set drg = ws.Range("I2:AD" & ws.Cells(ws.Rows.Count, "I").End(xlUp).Row)
Dim crg As Range: Set crg = drg.EntireRow.Columns("AI") ' (Helper) Column Range
crg.Value = False
Dim rrg As Range, rCell As Range, r As Long, c As Long, IsFound As Boolean
For Each rrg In drg.Rows
r = r + 1 ' for the (helper) column range
c = 0 ' for the header range
For Each rCell In rrg.Cells
c = c + 1
If StrComp(CStr(rCell.Value), "x", vbTextCompare) = 0 Then
If IsNumeric(Application.Match(CStr(hrg.Cells(c)), checking, 0)) _
Then IsFound = True: Exit For
End If
Next rCell
If IsFound Then crg.Cells(r).Value = True: IsFound = False
Next rrg
End Sub
I am trying to create a VBA function that loops through each cell in a range, checking if it is equal or not to the cell to the left of it, and if it is a certain color. If it's not equal to the left cell and is that certain color, it adds a number in the same row but a different column to a running sum.
For whatever reason, the condition of the left cell being equal to the current cell is not working: it will still include cells that are the same value as the cell to the left. How do I fix this?
Sub TestFormulas()
Dim x As Long
x = SumRenewed(Range("E2:E9000"))
MsgBox (x)
End Sub
' This function checks cell color and adds it to a sum if it is a certain color.
' It also checks to see if the cell is the same as what's to the left of it. If it is the same, it gets omitted.
' This prevents unnecessary older irrelevant month from being included.
Function SumRenewed(rRng As Range)
Dim lngSum As Long
Dim intIndex As Integer
Dim lngSomething As Variant
For Each cl In rRng
intIndex = cl.Interior.ColorIndex
If cl <> Left(cl, 1) And cl.Interior.ColorIndex = 43 Then '43 is the color index for light green
lngSomething = CLng(Cells(cl.Row, 2))
MsgBox (lngSomething)
lngSum = WorksheetFunction.Sum(lngSomething, lngSum)
lngSomething = CVar(lngSomething)
End If
Next cl
SumRenewed = lngSum
End Function
I have tried numerous workarounds for offsets, assigning Left(cl, 1) to a variable and changing the data type, and Googled every which way I can think for 2.5 days.
Sum Up Column If Matching Criteria (Incl. ColorIndex)
In VBA
Sub TestFormulas()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range
Set rg = ws.Range("E2", ws.Cells(ws.Rows.Count, "E").End(xlUp))
Dim MySum As Double
MySum = SumRenewed(rg, "D", "B", 43)
MsgBox MySum
End Sub
The Function
Function SumRenewed( _
ByVal SingleColumnRange As Range, _
ByVal CompareColumnID As Variant, _
ByVal SumColumnID As Variant, _
ByVal SingleColumnColorIndex As Long) _
As Double
Application.Volatile
Dim lrg As Range: Set lrg = SingleColumnRange.Columns(1)
Dim crg As Range: Set crg = lrg.EntireRow.Columns(CompareColumnID)
Dim srg As Range: Set srg = lrg.EntireRow.Columns(SumColumnID)
'Debug.Print lrg.Address, crg.Address, srg.Address
Dim lCell As Range ' Lookup cell
Dim r As Long ' Range Row
Dim lString As String ' Lookup String
Dim cString As String ' Compare String
Dim sValue As Variant ' Sum Value
Dim Total As Double ' Total Sum
For Each lCell In lrg.Cells
r = r + 1
lString = CStr(lCell.Value)
cString = CStr(crg.Cells(r).Value)
If StrComp(lString, cString, vbTextCompare) <> 0 Then ' not equal
If lCell.Interior.ColorIndex = SingleColumnColorIndex Then
sValue = srg.Cells(r).Value
'Debug.Print r, lString, cString, sValue
If VarType(sValue) = vbDouble Then ' is a number
Total = Total + sValue
End If
End If
End If
Next lCell
SumRenewed = Total
End Function
In Excel (not recommended)
Note that it will update on each calculation due to Application.Volatile. It will never update if the color has changed. Hence it is practically useless in Excel.
=SumRenewed(E2:E21,"D","B",43)
I'm creating a macro that is formatting a collection of files and a step in this process is to delete columns that aren't required, keeping a specific set of columns.
I know I can delete columns based on their location and I have this approach implemented already ie 1,3,7 etc or A, C, G etc. But I'm conscious that the report being used might change layout or add extra columns over time and I want to ensure the required columns are kept.
Ideally this code would cycle through each column header starting at A1 until the last column and delete an entire column if the header value isn't found in a list. This list will be an array captured from a range in one of the sheets in the workbook.
List = {Blue, Green, Orange}
Original Table
Blue
Red
Green
Orange
Black
row
row
row
row
row
Formatted Table
Blue
Green
Orange
row
row
row
Does anyone have any suggestions on the approach I could take to get this working or if it's even possible? Any help would be greatly appreciated
You might profit from the following approach by reordering a datafield array via Application.Index which allows even to move the existing columns to any new position.
Note: this flexible solution can be time consuming for greater data sets,
where I would prefer other ways you can find in a lot of answers at SO.
Sub ReorderColumns()
Const headerList As String = "Blue,green,Orange"
'a) define source range
Dim src As Range
Set src = Tabelle3.Range("A1:E100")
'b) define headers
Dim allHeaders: allHeaders = src.Resize(1).Value2
Dim newHeaders: newHeaders = Split(headerList, ",")
'c) get column positions in old headers
Dim cols
cols = getCols(newHeaders, allHeaders)
'd) define data
Dim data As Variant
data = src.Value2
'e) reorder data based on found column positions
data = Application.Index(data, Evaluate("row(1:" & UBound(data) & ")"), cols)
'f) overwrite source data
src = vbNullString ' clear
src.Resize(UBound(data), UBound(data, 2)) = data
End Sub
Help function getCols()
Function getCols(individualHeaders, allHeaders)
'Purp: get 1-based column numbers of found headers via Match
getCols = Application.Match(individualHeaders, allHeaders, 0) ' 1-based
End Function
Please, test the next code. It is compact and fast enough. It will build the columns to be deleted range using Application.Match for the two involved arrays (the existing headers one and the ones to be kept). This code assumes that the headers exist in the first row of the processed sheets, starting from A:A column (If starting from a different column, the code can be adapted:
Sub DeleteColunsNotInArrayDel()
Dim sh As Worksheet, arrStay, lastCol As Long, arrH, arrCols, rngDel As Range
Set sh = ActiveSheet 'use here the sheet you need to process
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column 'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
arrH = Application.Transpose(Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2)) 'existing headers array
arrCols = Application.IfError(Application.match(arrH, arrStay, 0), "xx") 'match the two arrays and place "xx" where no match has been found
makeColsRng(arrCols).Delete 'delete the columns range, at once
End Sub
Function makeColsRng(arr) As Range
Dim i As Long, colL As String, strAddr As String
For i = LBound(arr) To UBound(arr) 'iterate between the matched arrays array
If arr(i) = "xx" Then 'for the not matching case:
colL = Split(cells(1, i).Address, "$")(1) 'extract the letter of the respective column
strAddr = strAddr & colL & "1," 'build the string of the columns to be deleted range
End If
Next i
Set makeColsRng = Range(left(strAddr, Len(strAddr) - 1)).EntireColumn 'return the necessary range
End Function
In case of headers not starting from the first sheet column, the function can easily be adapted by adding a new parameter (the first column number) to be added when the range to be deleted is built.
The above suggested solution is a fancy one, just for the sake of showing the respective approach, which is not too often used. It may have a limitation of the range building, in case of a string bigger than 254 digits, No error handling for the case of everything matching (even, easy to be added). The next version is standard VBA, compact, more reliable, faster and easier to be understood:
Sub DeleteColunsRangeNotInArray()
Dim sh As Worksheet, arrStay, lastCol As Long, rngH As Range, rngDel As Range, i As Long
Set sh = ActiveSheet
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
Set rngH = sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)) 'existing headers range
For i = 1 To rngH.Columns.count
If IsError(Application.match(rngH(i).Value, arrStay, 0)) Then 'if not a match in arrStay:
addToRange rngDel, rngH(i) 'build a Union range
End If
Next i
'delete the not necessary columns at once:
If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
Dynamic Named Range
I think a dynamic named range is an excellent choice for storing and retrieving your required columns. Please see the link I provided from https://exceljet.net/ to setup your dynamic named range.
Generic formula =$A$2:INDEX($A:$A,COUNTA($A:$A))
Regular Expression Approach
After reading in your named range, one approach for testing your columns is using regular expressions. To use this you will need to set a library reference to Microsoft VBScript Regular Expressions 5.5. The pipe character | represents an or statement, so we can join our array using that delimiter.
Deleting Ranges in loops
When deleting columns or rows within a loop, the best approach I have found is to union the ranges together in a variable and execute the deletion in one go. This helps performance and it prevents errors from deleting ranges the loop is working on.
I do this so often that I created a custom function for this UnionRange
' Helper function that allows
' concatinating ranges together
Public Function UnionRange( _
ByRef accumulator As Range, _
ByRef nextRange As Range _
)
If accumulator Is Nothing Then
Set UnionRange = nextRange
Else
Set UnionRange = Union(accumulator, nextRange)
End If
End Function
Putting it all together
Below is my implementation of what your code could look like, just make sure to first:
Create a Dynamic Named Range and populate with your required headers
Add Microsoft VBScript Regular Expressions 5.5 reference
Update Sheet1 to whatever sheet your table exists (possibly change logic for finding header row based on your needs)
' Need Regular Expressions Referenced in order to work!
' #libraryReference {Microsoft VBScript Regular Expressions 5.5}
Public Sub DemoDeletingNonRequiredColumns()
' Make sure to create a named range
' otherwise this section will fail. In this
' example the named range is `RequiredColumns`
Dim requiredColumns() As Variant
requiredColumns = Application.WorksheetFunction.Transpose( _
Range("RequiredColumns").Value2 _
)
' To test if the column is in the required
' columns this method uses regular expressions.
With New RegExp
.IgnoreCase = True
' The pipe charactor is `or` in testing.
.Pattern = Join(requiredColumns, "|")
Dim headerRow As Range
' This example uses `Sheet1`, but update to
' the actual sheet you are using.
With Sheet1
Set headerRow = .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))
End With
Dim column As Range
For Each column In headerRow
' If the column name doesn't match the
' pattern, then concatenate it to the
' toDelete range.
If Not .Test(column.Value2) Then
Dim toDelete As Range
Set toDelete = UnionRange(toDelete, column.EntireColumn)
End If
Next
End With
' toDelete is used as it provides better performance
' and it also prevents errors when deleting columns
' while looping.
If Not toDelete Is Nothing Then
toDelete.Delete
Set toDelete = Nothing
End If
End Sub
Delete Columns Not In a List
Option Explicit
Sub DeleteIrrelevantColumns()
' Source - the worksheet containing the list of headers.
Const sName As String = "Sheet2"
Const sFirstCellAddress As String = "A2"
' Destination - the worksheet to be processed.
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim sData() As Variant
With sfCell
Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
sData = .Resize(slCell.Row - .Row + 1).Value
End With
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim sValue As Variant
Dim sr As Long
For sr = 1 To UBound(sData)
sValue = sData(sr, 1)
If Not IsError(sValue) Then ' exclude error values
If Len(sValue) > 0 Then ' exclude blanks
sDict(sValue) = Empty ' write
End If
End If
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range
With dfCell
Dim dlCell As Range: Set dlCell = _
.Resize(, dws.Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
Set drg = .Resize(, dlCell.Column - .Column + 1)
End With
Dim dData() As Variant: dData = drg.Value
Dim dCells As Range
Dim dValue As Variant
Dim dc As Long
For dc = 1 To UBound(dData, 2)
dValue = dData(1, dc)
If sDict.Exists(dValue) Then
' If duplicate columns, keep only the left-most.
sDict.Remove dValue
Else
' Combine the irrelevant header cells into a range.
If dCells Is Nothing Then
Set dCells = drg.Cells(dc)
Else
Set dCells = Union(dCells, drg.Cells(dc))
End If
End If
Next dc
' Delete columns in one go.
If Not dCells Is Nothing Then
dCells.EntireColumn.Delete
End If
' Inform.
If sDict.Count = 0 Then
MsgBox "Irrelevant columns deleted.", vbInformation
Else
MsgBox "Irrelevant columns deleted." & vbLf & vbLf _
& "Columns not found:" & vbLf _
& Join(sDict.Keys, vbLf), vbCritical
End If
End Sub
I want to change a value in a table based on an array of values.
These values are found through the application.match function.
Dim i As Integer
For i = 16 To 29
If ThisWorkbook.Sheets("General").Range("A" & i) = "" Then
Else
MsgBox ThisWorkbook.Sheets("General").Range("A" & i)
'Find value in Table
Dim Assignments As Worksheet
Dim TargetTable As ListObject
Dim TargetRW As Variant
Set Opdrachten = ThisWorkbook.Sheets("Jobs")
Set TargetTable = Opdrachten.ListObjects("Assignments")
TargetRW = Application.Match(i, TargetTable.ListColumns(1), 0)
MsgBox TargetRW 'I get an error at this point'
'Change value in Table
If Not IsError(TargetRW) Then
TargetTable.DataBodyRange.Cells(TargetRW, 6) = "Yes"
Else
MsgBox "Error, allready verified."
End If
End If
Next i
A VBA Lookup in an Excel Table
Tips
When writing to the same rows of cells of a column range, you usually want to loop through its cells, lookup the values in another column range and write to the same rows in another column, not the other way around.
A type mismatch error will occur if you try to return an error in a message box. You could use an if statement to check if the value is an error and then use CStr to return its string representation, e.g.:
If IsError(TargetRW) Then MsgBox CStr(TargetRW) Else MsgBox TargetRW
I've opted for the shorter IIf version of the same in the code.
Of course, you could also just do:
MsgBox CStr(TargetRW)
since the number is converted to a string anyways.
TargetTable.ListColumns(1) is a ListColumn object. To reference its range with the header or without it, you need to use either TargetTable.ListColumns(1).Range
or TargetTable.ListColumns(1).DataBodyRange (in this particular case) respectively.
The Code
Option Explicit
Sub LookupJobs()
' Source (read, compare)
Const swsName As String = "General"
Const sRangeAddress As String = "A16:A29"
' Destination (loop, compare, write)
Const dwsName As String = "Jobs"
Const dtblName As String = "Assignments"
Const dlcLookupIndex As Long = 1
Const dlcValueIndex As Long = 6
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Reference the source worksheet and the source column range.
Dim sws As Worksheet: Set sws = wb.Worksheets(swsName)
Dim srg As Range: Set srg = sws.Range(sRangeAddress)
' Reference the destination worksheet, table,
' lookup column range (compare) and value column range (write).
Dim dws As Worksheet: Set dws = wb.Worksheets(dwsName)
Dim dtbl As ListObject: Set dtbl = dws.ListObjects(dtblName)
Dim dlrg As Range: Set dlrg = dtbl.ListColumns(dlcLookupIndex).DataBodyRange
Dim dvrg As Range: Set dvrg = dtbl.ListColumns(dlcValueIndex).DataBodyRange
Dim srIndex As Variant ' current index of match in source range or error
Dim dlCell As Range ' current cell of the destination lookup range
Dim dValue As Variant ' value of the current cell
Dim drIndex As Long ' index of the current cell
For Each dlCell In dlrg.Cells
drIndex = drIndex + 1
dValue = dlCell.Value
If Not IsError(dValue) Then ' the cell contains an error value
If Len(dValue) > 0 Then ' the cell is not blank
srIndex = Application.Match(dValue, srg, 0)
'MsgBox IIf(IsError(srIndex), CStr(srIndex), srIndex)
If IsNumeric(srIndex) Then ' match found; write
dvrg.Cells(drIndex).Value = "Yes"
Else ' match not found
'MsgBox "Error, allready verified."
End If
'Else ' the cell is blank; do nothing
End If
'Else ' the cell contains an error value; do nothing
End If
Next dlCell
' Inform.
MsgBox "Jobs lookup finished.", vbInformation
End Sub
This question already has answers here:
Find last used cell in Excel VBA
(14 answers)
Closed 1 year ago.
I need to find the first blank cell in a column. The solution for this is easy assuming there are 2 or more filled cells in the column.
Range("A1").End(xlDown).Offset(1, 0).Select
This stops working if the only populated cell is A1 or if A1 is blank.
In these cases it will select the last cell in the workbook.
Is there any work around that will always select the first blank cell in the column even if that cell happens to be A1 or A2?
Here is a solution that tests if the cell we find is empty and if A1 is empty:
Dim Rng As Range
Set Rng = Range("A1").End(xlDown)
If Rng.Value = "" Then
If Range("A1").Value = "" Then
Range("A1").Select
Else
Range("A2").Select
End If
Else
Rng.Offset(1, 0).Select
End If
In the comment you write that you don't like the order of the code, here is another example:
If Range("A1").Value = "" Then
Range("A1").Select
ElseIf Range("A2").Value = "" Then
Range("A2").Select
Else
Range("A1").End(xlDown).Offset(1, 0).Select
End If
And here is another example that avoids the use of End() and Offset():
Dim Cnt As Long
Cnt = ActiveSheet.UsedRange.Rows.Count
If Cnt = 1 And Range("A1").Value = "" Then Cnt = 0
Range("A" & Cnt + 1).Select
If you add a header row, then this example works:
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1).Select
I always include a header row in all sheets with tabular data, to limit special cases - it's also more user friendly.
Find First Empty Cell by Looping
Empty
Except looping through cells, there are various more or less reliable ways to do it.
If there are hidden rows or columns, many of them will not work.
Even worse, if the worksheet is filtered, probably most of them will not work.
The Basic Loop
If you loop through the cells and test each one of them, you will surely get the correct result.
Function RefFirstEmptyCellInColumnBasic( _
ByVal FirstCell As Range) _
As Range
' Validate the given range ('FirstCell').
If FirstCell Is Nothing Then Exit Function
' Create a reference to the Column Range ('crg').
With FirstCell.Cells(1)
Dim crg As Range: Set crg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
' Loop.
Dim cCell As Range
' Loop through the cells of the Column Range...
For Each cCell In crg.Cells
' ... until an empty cell is found.
If IsEmpty(cCell) Then
' Create a reference to the current cell.
Set RefFirstEmptyCellInColumnBasic = cCell
Exit Function
End If
Next cCell
End Function
The issue is that it may take a long time. It will 'behave' for a few thousand rows but e.g. if the first empty cell is the last cell in the column, the previous code takes 'forever' (5s) on my machine.
Loop in Memory (Array)
To remedy this, you can introduce an array into the previous code which will reduce the execution time ten times (0.5s). (Note that it will roughly take 0.05s each time for just writing the values to the array.)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the top-most empty cell
' in the one-column range from the first cell of a range
' ('FirstCell') through the last cell in its column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefFirstEmptyCellInColumn( _
ByVal FirstCell As Range) _
As Range
' Validate the given range ('FirstCell').
If FirstCell Is Nothing Then Exit Function
' Create a reference to the Column Range ('crg').
With FirstCell.Cells(1)
Dim crg As Range: Set crg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
' Write the values from the Column Range to the Column Data Array ('cData').
Dim cData As Variant
If crg.Rows.Count = 1 Then ' only one cell
ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
Else
cData = crg.Value
End If
' Loop.
Dim r As Long
' Loop through the elements of the Column Data Array...
For r = 1 To UBound(cData, 1)
' ... until an empty value is found.
If IsEmpty(cData(r, 1)) Then
' Create a reference to the r-th cell of the Column Range.
Set RefFirstEmptyCellInColumn = crg.Cells(r)
Exit Function
End If
Next r
End Function
The Test
To test the previous you can do the following.
Sub RefFirstEmptyCellInColumnTEST()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range: Set fCell = ws.Range("A3")
' Empty
Dim feCell As Range: Set feCell = RefFirstEmptyCellInColumn(fCell)
If Not feCell Is Nothing Then
Debug.Print feCell.Address(0, 0)
End If
End Sub
Blank
You can do the same for blank cells i.e. empty cells or cells containing a single quote (') or cells containing formulas evaluating to "". Note that cells containing spaces are neither blank nor empty.
Function RefFirstBlankCellInColumnBasic( _
ByVal FirstCell As Range) _
As Range ' (Empty, ="" and ')
' Validate the given range ('FirstCell').
If FirstCell Is Nothing Then Exit Function
' Create a reference to the Column Range ('crg').
With FirstCell.Cells(1)
Dim crg As Range: Set crg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
' Loop.
Dim cCell As Range
' Loop through the cells of the Column Range...
For Each cCell In crg.Cells
' (exclude cell containing error value)
If Not IsError(cCell) Then
' ... until a blank cell is found.
If Len(cCell.Value) = 0 Then
' Create a reference to the current cell.
Set RefFirstBlankCellInColumnBasic = cCell
Exit Function
End If
End If
Next cCell
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the top-most blank cell
' in the one-column range from the first cell of a range
' ('FirstCell') through the last cell in its column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefFirstBlankCellInColumn( _
ByVal FirstCell As Range) _
As Range ' (Empty, ="" and ')
' Validate the given range ('FirstCell').
If FirstCell Is Nothing Then Exit Function
' Create a reference to the Column Range ('crg').
With FirstCell.Cells(1)
Dim crg As Range: Set crg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
' Write the values from the Column Range to the Column Data Array ('cData').
Dim cData As Variant
If crg.Rows.Count = 1 Then ' only one cell
ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
Else
cData = crg.Value
End If
' Loop.
Dim r As Long
' Loop through the elements of the Column Data Array...
For r = 1 To UBound(cData, 1)
' (exclude error values)
If Not IsError(cData(r, 1)) Then
' ... until a blank is found.
If Len(cData(r, 1)) = 0 Then
' Create a reference to the r-th cell of the Column Range.
Set RefFirstBlankCellInColumn = crg.Cells(r)
Exit Function
End If
End If
Next r
End Function
Sub RefFirstBlankCellInColumnTEST()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range: Set fCell = ws.Range("A3")
' Blank
Dim fbCell As Range: Set fbCell = RefFirstBlankCellInColumn(fCell)
If Not fbCell Is Nothing Then
Debug.Print fbCell.Address(0, 0)
End If
End Sub