0

I'm having a hard time solving a problem. I've just recently started coding and I would like to create a macro that checks 3 variables (1 for date and 2 for position) without using the Selection function.

What I'm trying to achieve is to have a cell that checks 1 cell with a date (A) to determine if the date is before today and if the cell is not blank. It would either write "Expired" (if the date is before today) or the text in the cell to the left.

It would then move on to the below cells and do this again. Even though this works, it is very slow and I was wondering if there was any other method I could use to speed this up (at 8000 lines this is really not worth it). Maybe use a filter?

Any help is much appreciated!

Dim status As String Dim exp As Date Dim i As Integer Dim n As Integer Dim m As Integer i = 0 n = 1 status = 1 m = 1 Do While status <> "" Cells.Find(What:="A", After:=ActiveCell, LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Activate ActiveCell.Offset(n, 0).Select exp = Selection Cells.Find(What:="B", After:=ActiveCell, LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Activate ActiveCell.Offset(m, 0).Select status = ActiveCell.Offset(i, -1).Value MsgBox (status) If exp <> 0 And exp < Date Then ActiveCell.FormulaR1C1 = "Expired" Else ActiveCell.FormulaR1C1 = status End If i = i - 1 n = n + 1 m = m + 1 Loop

Example

EDIT: I think this more or less shows what I would like to do in a simple way. The aim is to only change the Status text when the date is before today. However, there could be additional columns (like Amount) so I would like to avoid static ranges and in case of 25000 rows the selection method is VERRRY slow. I do feel like I've overcomplicated this a bit with the do while.

Improve this question
2
  • Can you screenshot what the sheet looks like? This should be relatively simple, but I would like to see what exactly you are expecting first. This actually sounds like you can just use formulas. Commented Jan 3, 2018 at 14:16
  • Here's the screenshot: i.sstatic.net/phMlC.png I've edited the OP to contain a bit more info. Commented Jan 3, 2018 at 16:18

3 Answers 3

Reset to default
1

You can grab all the values of a range object to a 2d array variable, and you work on the array instead. It is WAY MUCH faster

E.g. let's say you have many different values in the range a1:c6, you need to loop thru the values

Dim var2d As Variant, r As Range Set r = ActiveSheet.Range("A1:C6") var2d = r ' var2d becomes a 6x3 array Msgbox var2d(2,1) ' print value of cell A2 var2d(3,2) = "Expired" var2d(5,1) = 123 r.Value = var2d ' write the modified array back to a1:c6
Improve this answer
Sign up to request clarification or add additional context in comments.

10 Comments

Perhaps explain that this cryptic [a1:c6] notation is shorthand code for Application.Evaluate("A1:C6"), which is kind of a roundabout and inefficient way to refer to ActiveSheet.Range("A1:C6")?
What I only know is It's an efficient way for me to type on a smartphone :) also if you read that it can be SET to a Range variable you'll know that the notation evaluates as a range object
Thanks for the response! I haven't used a 2d array before, can the If Then Else get values/dates from this? I was also wondering if it were easier to just use an Autofilter to filter for the dates before today, that would exclude blank cells and I wouldn't need a 3rd column.
Of course! After you put x/y indices to an array it would act like an ordinary variable. Try changing all "cells" collection reference to "usedrange.cells", because "cells" means all cells of the sheet, but usedrange.cells doesn't include cells that are beyond the sheet's "last cell", see if it's faster
Try to open a sheet with that 25000 rows, and try "msgbox cells.count" and "msgbox usedrange.cells.count", you'll see what I mean
|
0

I've come up with some codings that is more suitable to the case you presented:

It will set up some testing data on a new workbook, and no column address is hardcoded.

It will also shows how to create a listobject and refer to its various elements in an object oriented way and without hard-coding address

Finally it uses the filter capability of the listobject to perform the filtering (it is more or less the same as the sheet-based autofilter)

Run the Main() sub to start the demo.

Const COL_FRUIT As String = "Fruit", COL_FRESHUNTIL As String = "Fresh Until", COL_STATUSTEXT = "Status text" Dim POS_FRUIT As Integer, POS_FRESHUNTIL As Integer, POS_STATUSTEXT As Integer Sub Main() Dim lo As ListObject SetupData lo lo.ListColumns(COL_FRUIT).Range.Select MsgBox "Fruit column" lo.ListRows(2).Range.Select MsgBox "2nd row" lo.ListColumns(COL_FRUIT).DataBodyRange.Select MsgBox "Fruit data" lo.Range.AutoFilter Field:=POS_FRESHUNTIL, Criteria1:= _ "<4/1/2018", Operator:=xlAnd lo.Range.AutoFilter Field:=POS_STATUSTEXT, Criteria1:= _ "=*exp*", Operator:=xlAnd MsgBox "Filter applied: " & vbCrLf & _ "Row 1 matched: " & (lo.ListRows(1).Range.Height <> 0) & vbCrLf & _ "Row 2 matched: " & (lo.ListRows(2).Range.Height <> 0) & vbCrLf & _ "Row 3 matched: " & (lo.ListRows(3).Range.Height <> 0) End Sub Sub SetupData(ByRef ref_lo As ListObject) Dim newwb As Workbook, currsh As Worksheet, vData As Variant, rData As Range, lo As ListObject Set newwb = Workbooks.Add Set currsh = newwb.Worksheets(1) Dim s As String vData = [{"Fruit", "Fresh Until", "Status text"; "Apple","03-03-2018","Fresh";"Apple","03-12-2017","Expired";"Apple","03-12-2017","Date over"}] POS_FRUIT = GetColPos(COL_FRUIT, vData) POS_FRESHUNTIL = GetColPos(COL_FRESHUNTIL, vData) POS_STATUSTEXT = GetColPos(COL_STATUSTEXT, vData) Set rData = currsh.Cells(1).Resize(UBound(vData, 1), UBound(vData, 2)) rData = vData Set ref_lo = currsh.ListObjects.Add(xlSrcRange, rData, , xlYes) ' or ListObjects("name_of_your_listobject") End Sub Function GetColPos(sCol As String, data As Variant) As Integer Dim ifr As Integer, ito As Integer, i As Integer ito = UBound(data, 2) ifr = LBound(data, 2) For i = ifr To ito If sCol = data(LBound(data, 1), i) Then GetColPos = i Exit Function End If Next GetColPos = -1 End Function
Improve this answer

2 Comments

to write value back to the listobject (e.g. write to status text): lo.ListRows(1).Range.cells(POS_STATUSTEXT) = "Expired"
Thank you very much, this seems to be it. I'll have to work with it a bit as it's a bit above my head right now, but the help is much appreciated!
0

You could do something like this

Dim status As String Dim exp As Date Dim i As Integer Dim n As Integer Dim m As Integer Dim c As Range, d As Range i = 0 n = 1 status = 1 m = 1 With ActiveSheet Set d = .Range("A1") Do While status <> "" Set c = .Cells.Find(what:="A", after:=d, LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not c Is Nothing Then exp = c.Offset(n, 0).Value2 Set d = .Cells.Find(what:="B", after:=c.Offset(n, 0), LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not d Is Nothing Then With d.Offset(m + i, -1) .Select status = .Value2 MsgBox status If exp <> 0 And exp < Date Then .Value2 = "Expired" Else .Value2 = status End If End With End If End If i = i - 1 n = n + 1 m = m + 1 Loop End With
Improve this answer

1 Comment

I went with another solution, but thanks for the help, much appreciated!

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.