Related
I am new to VBA. So usually I have to research stuff for my codes in order to make them work.
Now I am working on a code that has to get the values from cells with background colour that are different from -4142, and then putting those values in an array so that later I can insert those values in a dropdown list.
I was testing getting the values of the cells with different colours and putting them into arrays with the code I found in the answer of this question:
Appending a dynamic array in VBA
but for some reason, when I run the code I get the error 13 incompatible types (I don't know if the error message is that in english because my vba is in another language, but the error number is 13 non the less), in the line myArray(X) = cell.Address
It may be very silly but I dont know what to do.
Sub SelectByColor()
Dim cell As Range
Dim rng As Range
Dim LR As Long
Dim myArray() As Double, X As Long
X = 0
'For understanding LR = Last Row
LR = Range("B:B").SpecialCells(xlCellTypeLastCell).Row
ReDim Preserve myArray(X)
Set rng = Range("B2:B" & LR)
For Each cell In rng.Cells
If cell.Interior.ColorIndex <> -4142 Then
myArray(X) = cell.Address
X = X + 1
If X < N Then ReDim Preserve myArray(0 To X)
mystr = mystr & cell.Address & ","
End If
Next cell
mystr = Left(mystr, Len(mystr) - 1)
MsgBox mystr
MsgBox myArray(X)
End Sub
The mystr part is to see if the code would be getting the correct values, and it is, but it is not appending in the array.
(a) You get your runtime error because you declares your array to hold numbers, but you are trying to write addresses (=strings) into it. An cell address (eg $A$1) cannot be converted into a number and therefore VBA throws that error 13.
(b) A list of values used as Data Validation can be created by a range of cells or by a (hardcoded) list of values. However, the range need to be contiguous, which is not the case for your requirements.
So what you need is a list of values. The values need to be separated by ",". You can do the by creating an array as you do in your code and then use the Join-function. However, the array needs to be of type String or Variant, it will not work with Double.
As I don't like to use Redim Preserve in a Loop (very inefficient), I changed the logic by sizing the array with the maximum of possible values (LR) and then use only a single Redim to remove unused entries after the values are filled.
ReDim myArray(LR)
Dim X As Long, rng as Range, cell as Range
Set rng = ActiveSheet.Range("B2:B" & LR)
For Each cell In rng.Cells
If cell.Interior.ColorIndex <> -4142 and not isError(cell.value) Then
myArray(X) = cell.Value
X = X + 1
End If
Next cell
Redim Preserve myArray(X) ' Remove unused entries
Set the validiation:
With Selection.Validation ' <-- Replace Selection with the Range where you want to apply the validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Join(myArray, ",")
End With
I have the below loop in VBA:
For i = 1 To Range("B" & "65536").End(xlUp).Row Step 1
Companies = Range("A" & i).Value
Next i
MsgBox Companies 'Output Company Name (One time)
So above loop iterates through rows, that all have a company name in Column "A". I want to add all these company names to an array, so I can print them all out later on (after the loop)
How can I dynamically add the Companies value to an array, and use it later on?
you don't need Loop
Just try this :
Dim DirArray As Variant
DirArray = Range("A1:A5000").Value
I think something like this is what you're looking for.
Sub tgr()
'Declare variables
Dim ws As Worksheet
Dim Companies As Variant
Dim i As Long
'Always fully qualify which workbook and worksheet you're looking at
Set ws = ActiveWorkbook.ActiveSheet
'You can assing a Variant variable to the value of a range
' and it will populate the variable as an array if there
' is more than one cell in the range
'Note that I am going off of column B as shown in your original code,
' and then using Offset(, -1) to get the values of column A
Companies = ws.Range("B1", ws.Cells(ws.Rows.Count, "B").End(xlUp)).Offset(, -1).Value
If IsArray(Companies) Then
'More than one company found, loop through them
For i = LBound(Companies, 1) To UBound(Companies, 1)
MsgBox "Company " & i & ":" & Chr(10) & _
Companies(i, 1)
Next i
Else
'Only one company found
MsgBox Companies
End If
End Sub
If you need an array, which is increased every time and still saves its contents, something like this should work:
Option Explicit
Public Sub TestMe()
Dim i As Long
Dim companies() As Variant
ReDim companies(0)
For i = 1 To 20
ReDim Preserve companies(UBound(companies) + 1)
companies(UBound(companies)) = Range("A" & i)
Next i
End Sub
If you need simply need to take the values to array, then the answer of #Leo R. is probably the easiest way to achieve it.
Building off of one of my past questionsWhat I'm looking to accomplish:
I'm looking to find and highlight duplicate Upcharges using VBA code based on multiple criteria:
Product's XID (Column A)
Upcharge Criteria 1 (Column CT)
Upcharge Criteria 2 (Column CU)
Upcharge Type (Column CV) and
Upcharge Level (Column CW)
If there is more than one instance/row in a spreadsheet that share/match ALL of these criteria then that means the Upcharge is a duplicate. As seen in my previous post linked above:
What I've tried:
Created a general formula (see below) that is inserted into a Helper column and copied all the way down the spreadsheet which points out which Upcharges are duplicate. This method was too resource heavy and took too long (8-10 minutes for all the formulas to calculate, but doesn't lag when filtering). Then I tried
Evolved the general formula into a Conditional Formatting Formula and applied it to the Upcharge Name column via VBA code.(Takes same amount of time AND lags when filtering)
I've also looked into possibly using a scripting.dictionary, but I'm not sure how (or if) that would work with a multi-dimensional array.
Now I've finally found the method I think will be much faster,
The faster method I'm looking to use:
Dumping the aforementioned columns into a multi-dimensional array, finding the duplicate "rows" in the array, then highlighting the corresponding spreadsheet rows.
My attempt at the faster method:
Here's how I populate the multi-dimensional array
Sub populateArray()
Dim arrXID() As Variant, arrUpchargeOne() As Variant, arrUpchargeTwo() As Variant, arrUpchargeType() As Variant, arrUpchargeLevel() As Variant
Dim arrAllData() As Variant
Dim i As Long, lrow As Long
lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
arrXID = Range("A2:A" & lrow) 'amend column number
arrUpchargeOne = Range("CT2:CT" & lrow)
arrUpchargeTwo = Range("CU2:CU" & lrow)
arrUpchargeType = Range("CV2:CV" & lrow)
arrUpchargeLevel = Range("CW2:CW" & lrow)
ReDim arrAllData(1 To UBound(arrXID, 1), 4) As Variant
For i = 1 To UBound(arrXID, 1)
arrAllData(i, 0) = arrXID(i, 1)
arrAllData(i, 1) = arrUpchargeOne(i, 1)
arrAllData(i, 2) = arrUpchargeTwo(i, 1)
arrAllData(i, 3) = arrUpchargeType(i, 1)
arrAllData(i, 4) = arrUpchargeLevel(i, 1)
Next i
End Sub
I can get the columns into the array, but I get stuck from there. I'm not sure how to go about checking for the duplicate "rows" in the array.
My questions:
Is there a way I can apply my formula (see below) from my first attempt in my previous post and apply it inside the array?:
Or, even better, is there a faster way I can find the duplicate "rows" inside the array?
Then how could I go about highlighting the Upcharge Name (CS) cell in the spreadsheet rows that correspond with the "rows" in the array that were flagged as duplicates?
Formula from my previous post for reference:
=AND(SUMPRODUCT(($A$2:$A$" & lastRow & "=$A2)*($CT$2:$CT$" & lastRow & "=$CT2)*($CU$2:$CU$" & lastRow & "=$CU2)*($CV$2:$CV$" & lastRow & "=$CV2)*($CW$2:$CW$" & lastRow & "=$CW2))>1,$CT2 <> """")"
Returns TRUE if Upcharge is a duplicate
You say identify duplicates; I hear Scripting.Dictionary object.
Public Sub lminyDupes()
Dim d As Long, str As String, vAs As Variant, vCTCWs As Variant
Dim dDUPEs As Object '<~~ Late Binding
'Dim dDUPEs As New Scripting.Dictionary '<~~ Early Binding
Debug.Print Timer
Application.ScreenUpdating = False '<~~ uncomment this once you are no longer debugging
'Remove the next line with Early Binding¹
Set dDUPEs = CreateObject("Scripting.Dictionary")
dDUPEs.comparemode = vbTextCompare
With Worksheets("Upcharge") '<~~ you know what worksheet you are supposed to be on
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
.Columns(97).Interior.Pattern = xlNone '<~~ reset column CS
'the following is intended to mimic a CF rule using this formula
'=AND(COUNTIFS(A:A, A2, CT:CT, CT2, CU:CU, CU2, CV:CV, CV2, CW:CW, CW2)>1, SIGN(LEN(CT2)))
vAs = .Columns(1).Value2
vCTCWs = Union(.Columns(98), .Columns(99), .Columns(100), .Columns(101)).Value2
For d = LBound(vAs, 1) To UBound(vAs, 1)
If CBool(Len(vCTCWs(d, 1))) Then
'make a key of the criteria values
str = Join(Array(vAs(d, 1), vCTCWs(d, 1), vCTCWs(d, 2), vCTCWs(d, 3), vCTCWs(d, 4)), ChrW(8203))
If dDUPEs.exists(str) Then
'the comboned key exists in the dictionary; append the current row
dDUPEs.Item(str) = dDUPEs.Item(str) & Chr(44) & "CS" & d
Else
'the combined key does not exist in the dictionary; store the current row
dDUPEs.Add Key:=str, Item:="CS" & d
End If
End If
Next d
'reuse a variant var to provide row highlighting
Erase vAs
For Each vAs In dDUPEs.keys
'if there is more than a single cell address, highlight all
If CBool(InStr(1, dDUPEs.Item(vAs), Chr(44))) Then _
.Range(dDUPEs.Item(vAs)).Interior.Color = vbRed
Next vAs
End With
End With
End With
dDUPEs.RemoveAll: Set dDUPEs = Nothing
Erase vCTCWs
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
This seems faster than the formula approach.
¹ If you plan to convert the late binding of the Scripting.Dictionary object to early binding, you must add Microsoft Scripting Runtime to the VBE's Tools ► References.
Conditional Formatting and Filtering
SUMPRODUCT vs COUNTIFS
First off, your choice of functions was inappropriate for such a large number of rows coupled with several conditions. A COUNTIFS function can perform many of the same multiple criteria operations that a SUMPRODUCT function can but in typically 25-35% of the calculation load and time. Additionally, full column references can be used without detriment in COUNTIFS as the column references are internally truncated at the limits of the Worksheet.UsedRange property.
Your standard formula can be written with COUNTIFS as,
=AND(COUNTIFS(A:A, A2, CT:CT, CT2, CU:CU, CU2, CV:CV, CV2, CW:CW, CW2)>1, CT2<>"")
'... or,
=COUNTIFS(A:A, A2, CT:CT, CT2, CT:CT, "<>", CU:CU, CU2, CV:CV, CV2, CW:CW, CW2)>1
Bringing the non-blank column CT condition directly into the COUNTIFS function actually improved calculation time slightly.
Only Calculate When You Have To
The original formula can be broken down to two main conditions.
Is the cell in column CT non-blank?
Do the values in five columns match the same five columns any other row?
A rudimentary IF function halts processing if the condition is not true. If the test for a non-blank cell in column CT is moved into a wrapping IF then the COUNTIFS (the bulk of the calculation) will only be processed if there is a value in the current row's CT column.
The improved standard formula becomes,
=IF(CT2<>"", COUNTIFS(A:A, A2, CT:CT, CT2, CU:CU, CU2, CV:CV, CV2, CW:CW, CW2)>1)
The benefits for this modification depend upon the number of blank cells in column CT. If only 1% of the 15,000 cells are blank, very little improvement will be noticed. However, if 50% of the cells in column CT are typically blank there will be a substantial improvement as you are literally knocking your calculation cycles in half.
Sorting the Data to Limit the Ranges
By far, the biggest calculation parasite is with the COUNTIFS looking through 15,000 rows of data in five separate columns. If the data was sorted on one or more of the criteria columns then it becomes unnecessary to look through all 15,000 rows for matches to all five columns of criteria.
For the purpose of this exercise, it will be assumed that column A is sorted in an ascending manner. If you want to test the hypothesis discussed here, sort the data now.
The INDEX function does more than return a value; it actually returns a valid cell address. When used in its most common lookup capacity, you see the value returned but in reality, unlike a similar VLOOKUP operation which only return the cell's value, INDEX is returning the actual cell; e.g. =A1, not the 99 that A1 contains. This hyper-functionality can be used to create valid ranges that can be used in other functions. e.g. A2:A9 can also be written as INDEX(A:A, 2):INDEX(A:A, 9).
This functionality cannot be used directly within a Conditional Formatting rule. However, it can be used in a Named Range and a Named Range can be used in a Conditional Formatting rule.
tl;dr
Sub lminyCFrule()
Debug.Print Timer
'Application.ScreenUpdating = False '<~~ uncomment this once you are no longer debugging
On Error Resume Next '<~~ needed for deleting objects without checking to see if they exist
With Worksheets("Upcharge") '<~~ you know what worksheet you are supposed to be on
If .AutoFilterMode Then .AutoFilterMode = False
'delete any existing defined name called 'localXID' or 'local200'
With .Parent
.Names("localXID").Delete
.Names("local200").Delete
End With
'create a new defined name called 'localXID' for CF rule method 1
.Names.Add Name:="localXID", RefersToR1C1:= _
"=INDEX('" & .Name & "'!C1:C104, MATCH('" & .Name & "'!RC1, '" & .Name & "'!C1, 0), 0):" & _
"INDEX('" & .Name & "'!C1:C104, MATCH('" & .Name & "'!RC1, '" & .Name & "'!C1 ), 0)"
'create a new defined name called 'local200' for CF rule method 2
.Names.Add Name:="local200", RefersToR1C1:= _
"=INDEX(Upcharge!C1:C104, MAX(2, ROW()-100), 0):INDEX(Upcharge!C1:C101, ROW()+100, 0)"
With .Cells(1, 1).CurrentRegion
'sort on column A in ascending order
.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
'create a CF rule on column CS
With .Resize(.Rows.Count - 1, 1).Offset(1, 96)
With .FormatConditions
.Delete
' method 1 and method 2. Only use ONE of these!
' method 1 - definitively start and end of XIDs in column A (slower, no mistakes)
'.Add Type:=xlExpression, Formula1:= _
"=IF(CT2<>"""", COUNTIFS(INDEX(localXID, 0, 1), A2, INDEX(localXID, 0, 98), CT2," & _
"INDEX(localXID, 0, 99), CU2, INDEX(localXID, 0, 100), CV2," & _
"INDEX(localXID, 0, 101), CW2)-1)"
' method 2 - best guess at start and end of XIDs in column A (faster, guesswork at true scope)
.Add Type:=xlExpression, Formula1:= _
"=IF(CT2<>"""", COUNTIFS(INDEX(local200, 0, 1), A2, INDEX(local200, 0, 98), CT2," & _
"INDEX(local200, 0, 99), CU2, INDEX(local200, 0, 100), CV2," & _
"INDEX(local200, 0, 101), CW2)-1)"
End With
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 3
End With
'Filter based on column CS is red
.Columns(97).AutoFilter Field:=1, Criteria1:=vbRed, Operator:=xlFilterCellColor
End With
End With
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
While not screaming fast, this does the job handily. The 'best guess' is faster than the 'definitive start and finish' but you run the risk of not completely covering the scope of the duplicates in column A. Of course, the offsets (e.g. 100 up and down) that control the scope could be adjusted.
Why don't you remove the Indirect() and replace the Countif() function with some stable Row reference. Since Indirect() part is a volatile and instead of using Indirect() you can straight away use some stable row reference like $A$2:$A$50000 which may show some significant change in performance.
Or
Use Create Table for your data. Use Table reference in your formula which will work faster than Indirect() reference.
Edit
Your actual formula
=AND(SUMPRODUCT(($A$2:$A$500=$A2)*($CU$2:$CU$500=$CU2)*($CV$2:$CV$500=$CV2)*($CW$2:$CW$500=$CW2)*($CX$2:$CX$500=$CX2))>1,$CU2 <> "")
Why don't you convert it to Counti(S) with stable reference like the below?
=AND(COUNTIFS($A$2:$A$500,$A2,$CU$2:$CU$500,$CU2,$CV$2:$CV$500,$CV2,$CW$2:$CW**$500,$CW2,$CX$2:$CX$500,$CX2)>1,$CU12<>"")
Consider an SQL solution as this is a typical aggregate group by query where you filter for counts greater than 1. To go about your route requires many conditional logic within the loop across all elements of array.
While I recommend you simply import your data into a database like Excel's sibling MS Access, Excel can run SQL statements on its own workbook using an ADO connection (not to get into particulars but both Excel and Access uses the same Jet/ACE engine). And one good thing is you seem to be set up to run such a query with the table like structure of named columns.
The below example references your fields in a worksheet called Data (Data$) and query outputs to a worksheet called Results (with headers). Change names as needed. Two connection strings are included (one of which is commented out). Hopefully it runs on your end!
Sub RunSQL()
Dim conn As Object, rst As Object
Dim i As Integer, fld As Object
Dim strConnection As String, strSQL As String
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' Connection and SQL Strings
' strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
' & "DBQ=C:\Path\To\Workbook.xlsm;"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source='C:\Path\To\Workbook.xlsm';" _
& "Extended Properties=""Excel 8.0;HDR=YES;"";"
strSQL = " SELECT [Data$].[Product's XID], [Data$].[Upcharge Criteria 1]," _
& " [Data$].[Upcharge Criteria 2], [Data$].[Upcharge Type]," _
& " [Data$].[Upcharge Type], [Data$].[Upcharge Level]" _
& " FROM [Data$]" _
& " GROUP BY [Data$].[Product's XID], [Data$].[Upcharge Criteria 1]," _
& " [Data$].[Upcharge Criteria 2], [Data$].[Upcharge Type]," _
& " [Data$].[Upcharge Type], [Data$].[Upcharge Level]," _
& " [Data$].[Product's XID]" _
& " HAVING COUNT(*) > 1;"
' Open the db connection
conn.Open strConnection
rst.Open strSQL, conn
' Column headers
i = 0
Worksheets("Results").Range("A1").Activate
For Each fld In rst.Fields
ActiveCell.Offset(0, i) = fld.Name
i = i + 1
Next fld
' Data rows
Worksheets("Results").Range("A2").CopyFromRecordset rst
rst.Close
conn.Close
End Sub
This might work like a magic trick, but not sure if it would work.
Could you just create another supportive (temporary) column, concatenating all four criteria?
ZZ_Temp = concatenate (CS; CV; CZ; etc)
This way, I suppose, you could show/highlight duplicates a lot faster.
I was working on a solution to another question of mine when I stumble across this helpful question and answer. However implementing the answer given by Control Freak over there throws me a Type Mismatch error as soon as I exit the function and return to my code on the line: Years = ReDimPreserve(Years, i, 3). I'm not that skilled of a programmer to figure out what is going wrong here, so can anybody shed some light on this.
Here is my code:
Sub DevideData()
Dim i As Integer
Dim Years() As String
ReDim Years(1, 3)
Years(1, 1) = Cells(2, 1).Value
Years(1, 2) = 2
i = 2
ThisWorkbook.Worksheets("Simple Boundary").Activate
TotalRows = ThisWorkbook.Worksheets("Simple Boundary").Range("A100000").End(xlUp).row
For row = 3 To TotalRows
Years = ReDimPreserve(Years, i, 3)
If Not Cells(row, 1).Value = Cells(row - 1, 1).Value Then
Years(i - 1, 3) = row - 1
Years(i, 1) = Cells(row, 1).Value
Years(i, 2) = row
i = i + 1
End If
Next row
End Sub
And here is the function as written by Control Freak:
Public Function ReDimPreserve(aArrayToPreserve, nNewFirstUBound, nNewLastUBound)
ReDimPreserve = False
'check if its in array first
If IsArray(aArrayToPreserve) Then
'create new array
ReDim aPreservedArray(nNewFirstUBound, nNewLastUBound)
'get old lBound/uBound
nOldFirstUBound = UBound(aArrayToPreserve, 1)
nOldLastUBound = UBound(aArrayToPreserve, 2)
'loop through first
For nFirst = LBound(aArrayToPreserve, 1) To nNewFirstUBound
For nLast = LBound(aArrayToPreserve, 2) To nNewLastUBound
'if its in range, then append to new array the same way
If nOldFirstUBound >= nFirst And nOldLastUBound >= nLast Then
aPreservedArray(nFirst, nLast) = aArrayToPreserve(nFirst, nLast)
End If
Next
Next
'return the array redimmed
If IsArray(aPreservedArray) Then ReDimPreserve = aPreservedArray
End If
End Function
I promised a fuller answer. Sorry it is later than I expected:
I got tied up with another problem,
Technique 1, which I was expecting to recommend, did not work as I expected so I added some other techniques which are much more satisfactory.
As I said in my first comment:
Public Function ReDimPreserve(aArrayToPreserve, nNewFirstUBound, nNewLastUBound)
causes aArrayToPreserve to have the default type of Variant. This does not match:
Dim Years() As String
As you discovered, redefining Years as a Variant, fixes the problems. An alternative approach would be to amend the declaration of ReDimPreserve so aArrayToPreserve is an array of type String. I would not recommend that approach since you are storing both strings and numbers in the array. A Variant array will handle either strings or numbers while a String array can only handle numbers by converting them to strings for storage and back to numbers for processing.
I tried your macro with different quantities of data and different amendments and timed the runs:
Rows of data Amendment Duration of run
3,500 Years() changed to Variant 4.99 seconds
35,000 Years() changed to Variant 502 seconds
35,000 aArrayToPreserve changed to String 656 seconds
As I said in my second comment, ReDim Preserve is slow for both the inbuilt method and the VBA routine you found. For every call it must:
find space for the new larger array
copy the data from the old array to the new
release the old array for garbage collection.
ReDim Preserve is a very useful method but it must be used with extreme care. Sometimes I find that sizing an array to the maximum at the beginning and using ReDim Preserve to cut the array down to the used size at the end is a better technique. The best techniques shown below determine the number of entries required before sizing the array.
At the bottom of your routine, I added:
For i = LBound(Years, 1) To LBound(Years, 1) + 9
Debug.Print Years(i, 0) & "|" & Years(i, 1) & "|" & Years(i, 2) & "|" & Years(i, 3)
Next
For i = UBound(Years, 1) - 9 To UBound(Years, 1)
Debug.Print Years(i, 0) & "|" & Years(i, 1) & "|" & Years(i, 2) & "|" & Years(i, 3)
Next
This resulted in the following being output to the Immediate Window:
|||
|AAAA|2|2
|AAAB|3|4
|AAAC|5|7
|AAAD|8|11
|AAAE|12|16
|AAAF|17|22
|AAAG|23|23
|AAAH|24|25
|AAAI|26|28
|AOUJ|34973|34976
|AOUK|34977|34981
|AOUL|34982|34987
|AOUM|34988|34988
|AOUN|34989|34990
|AOUO|34991|34993
|AOUP|34994|34997
|AOUQ|34998|35002
|AOUR|35003|
|||
Since you have called the array Years, I doubt my string values are anything like yours. This does not matter. What matters, is that I doubt this output was exactly what you wanted.
If you write:
ReDim Years(1, 3)
The lower bounds are set to the value specified by the Option Base statement or zero if there is no Option Base statement. You have lower bounds for both dimensions of zero which you do not use. This is the reason for the “|||” at the top. There is another “|||” at the end which means you are creating a final row which you are not using. The final used row does not have an end row which I assume in a mistake.
When I can divide a routine into steps, I always validate the result of one step before advancing to the next. That way, I know any problems are within the current step and not the result of an error in an earlier step. I use Debug.Print to output to the Immediate Window most of the time. Only if I want to output a lot of diagnostic information will I write to a text file. Either way, blocks of code like mine are a significant aid to rapid debugging of a macro.
I would never write ReDim Years(1, 3). I always specify the lower bound so as to be absolutely clear. VBA is the only language I know where you can specify any value for the lower bound (providing it is less than the upper bound) so I will specify non-standard values if is helpful for a particular problem. In this case, I see not advantage to a lower bound other than one so that is what I have used.
With two dimensions arrays it is conventional to have columns as the first dimension and rows as the second. One exception is for arrays read from or to be written to a worksheet for which the dimensions are the other way round. You have rows as the first dimension. If you have used the conventional sequence you could have used the ReDim Preserve method, thereby avoiding the RedimPreserve function and the problem of non-matching types.
Technique 1
I expected this to be the fastest technique. Experts advise us to avoid “re-inventing the wheel”. That is, if Excel has a routine that will do what you want, don’t code an alternative in VBA. However, I have found a number of examples where this is not true and I discovered this technique was one of them.
The obvious technique here is to use Filter, then create a range of the visible rows using SpecialCells and finally process each row in this range. I have used this technique very successfully to meet other requirements but not here.
I did not know the VBA to select unique rows so started the macro recorder and filtered my test data from the keyboard to get:
Range("A1:A35000").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
My past uses of Filter have all converted to AutoFilter which I have found to give acceptable performance. This converted to AdvancedFilter which took 20 seconds both from the keyboard and from VBA. I do not know why it is so slow.
The second problem was that:
Set RngUnique = .Range(.Cells(1, 1), .Cells(RowLast, 1)) _
.SpecialCells(xlCellTypeVisible)
was rejected as “too complicated”.
Not being able to get the visible rows as a range means the benefits of Filter are not really available. I have counted the visible rows to simulate having RngUnique.Rows.Count. This shows the technique which has always worked with AutoFilter. If AdvancedFilter had reported the unique rows in an accepted time I might have investigated this problem but under the circumstances it does not seem worth the effort.
The macro demonstrating this technique is:
Option Explicit
Sub Technique1()
' * Avoid using meaningless names like i. Giving every variable a meaningful
' name is helpful during development and even more helpful when you return
' to the macro in six months for maintenence.
' * My naming convention is use a sequence of keywords. The first keyword
' identifies what type of data the variable holds. So "Row" means it holds
' a row number. Each subsequent keyword narrows the scope. "RowSb" is a
' row of the worksheet "Simple Boundary" and "RowYears" is a row of the Years
' array. "RowSbCrnt"is the current row of the worksheet "Simple Boundary".
' * I can look at macros I wrote years ago and know what all the variables are.
' You may not like my convention. Fine, development your own but do not
' try programming with random names.
' * Avoid data type Integer which specifies a 16-bit whole number and requires
' special processing on 32 and 64-bit computers. Long is now the recommended
' data type for whole numbers.
Dim NumRowsVisible As Long
Dim RowSbCrnt As Long
Dim RowSbLast As Long
Dim RowYearsCrnt As Long
Dim TimeStart As Double
Dim Years() As Variant
TimeStart = Timer ' Get the time as seconds since midnight to nearest .001
' of a second
' This can save significant amounts of time if the macro amends the
' screen or switches between workbooks.
Application.ScreenUpdating = False
With Worksheets("Simple Boundary")
' Rows.Count avoiding having to guess how many rows will be used
RowSbLast = .Cells(Rows.Count, "A").End(xlUp).Row
' Hide non-unique rows
With .Range(.Cells(1, 1), .Cells(RowSbLast, 1))
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End With
' Count number of unique rows.
' It is difficult to time small pieces of code because OS routines
' can execute at any time. However, this count takes less than .5
' of a second with 35,000 rows.
NumRowsVisible = 0
For RowSbCrnt = 2 To RowSbLast
If Not .Rows(RowSbCrnt).Hidden Then
NumRowsVisible = NumRowsVisible + 1
End If
Next
' Use count to ReDim array to final size.
ReDim Years(1 To 3, 1 To NumRowsVisible)
RowYearsCrnt = 1
Years(1, RowYearsCrnt) = .Cells(2, 1).Value
Years(2, RowYearsCrnt) = 2
For RowSbCrnt = 3 To RowSbLast
If Not .Rows(RowSbCrnt).Hidden Then
Years(3, RowYearsCrnt) = RowSbCrnt - 1
RowYearsCrnt = RowYearsCrnt + 1
Years(1, RowYearsCrnt) = .Cells(RowSbCrnt, 1).Value
Years(2, RowYearsCrnt) = RowSbCrnt
End If
Next
' Record final row for final string
Years(3, RowYearsCrnt) = RowSbLast
.ShowAllData ' Clear AdvancedFilter
End With
Application.ScreenUpdating = True
Debug.Print "Duration: " & Format(Timer - TimeStart, "#,##0.000")
' Output diagnostics
For RowYearsCrnt = 1 To 9
Debug.Print Years(1, RowYearsCrnt) & "|" & _
Years(2, RowYearsCrnt) & "|" & _
Years(3, RowYearsCrnt) & "|"
Next
' Note that rows are now in the second dimension hence the 2 in UBound(Years, 2)
For RowYearsCrnt = UBound(Years, 2) - 9 To UBound(Years, 2)
Debug.Print Years(1, RowYearsCrnt) & "|" & _
Years(2, RowYearsCrnt) & "|" & _
Years(3, RowYearsCrnt) & "|"
Next
End Sub
The output to the Immediate Window is:
Duration: 20.570
AAAA|2|2|
AAAB|3|4|
AAAC|5|7|
AAAD|8|11|
AAAE|12|16|
AAAF|17|22|
AAAG|23|23|
AAAH|24|25|
AAAI|26|28|
AOUI|34970|34972|
AOUJ|34973|34976|
AOUK|34977|34981|
AOUL|34982|34987|
AOUM|34988|34988|
AOUN|34989|34990|
AOUO|34991|34993|
AOUP|34994|34997|
AOUQ|34998|35002|
AOUR|35003|35008|
As you can see the last row is correct. A duration of 20 seconds is better than the 8 minutes of your technique but I am sure we can do better.
Technique 2
The next macro is similar to the last one but it counts the unique rows rather than use AdvancedFilter to hide the non-unique rows. This macro has a duration of 1.5 seconds with 35,000 rows. This demonstrates that counting how many rows are required for an array in a first pass of the data is a viable approach. The diagnostic output from this macro is the same as above.
Sub Technique2()
Dim NumRowsUnique As Long
Dim RowSbCrnt As Long
Dim RowSbLast As Long
Dim RowYearsCrnt As Long
Dim TimeStart As Double
Dim Years() As Variant
TimeStart = Timer ' Get the time as seconds since midnight to nearest .001
' of a second
With Worksheets("Simple Boundary")
RowSbLast = .Cells(Rows.Count, "A").End(xlUp).Row
' Count number of unique rows.
' Assume all data rows are unique until find otherwise
NumRowsUnique = RowSbLast - 1
For RowSbCrnt = 3 To RowSbLast
If .Cells(RowSbCrnt, 1).Value = .Cells(RowSbCrnt - 1, 1).Value Then
NumRowsUnique = NumRowsUnique - 1
End If
Next
' * Use count to ReDim array to final size.
' * Note that I have defined the columns as the first dimension and rows
' as the second dimension to match convention. Had I wished, this would
' have allowed me to use the standard ReDim Preserve which can only
' adjust the last dimension. However, this does not match the
' syntax of Cells which has the row first. It may have been better to
' maintain your sequence so the two sequences were the same.
ReDim Years(1 To 3, 1 To NumRowsUnique)
RowYearsCrnt = 1
Years(1, RowYearsCrnt) = .Cells(2, 1).Value
Years(2, RowYearsCrnt) = 2
For RowSbCrnt = 3 To RowSbLast
If .Cells(RowSbCrnt, 1).Value <> .Cells(RowSbCrnt - 1, 1).Value Then
Years(3, RowYearsCrnt) = RowSbCrnt - 1
RowYearsCrnt = RowYearsCrnt + 1
Years(1, RowYearsCrnt) = .Cells(RowSbCrnt, 1).Value
Years(2, RowYearsCrnt) = RowSbCrnt
End If
Next
' Record final row for final string
Years(3, RowYearsCrnt) = RowSbLast
End With
Debug.Print "Duration: " & Format(Timer - TimeStart, "#,##0.000")
' Output diagnostics
For RowYearsCrnt = 1 To 9
Debug.Print Years(1, RowYearsCrnt) & "|" & _
Years(2, RowYearsCrnt) & "|" & _
Years(3, RowYearsCrnt) & "|"
Next
' Note that rows are now in the second dimension hence the 2 in UBound(Years, 2)
For RowYearsCrnt = UBound(Years, 2) - 9 To UBound(Years, 2)
Debug.Print Years(1, RowYearsCrnt) & "|" & _
Years(2, RowYearsCrnt) & "|" & _
Years(3, RowYearsCrnt) & "|"
Next
End Sub
Technique 3
The next macro is only slightly changed from the last.
Firstly, I have replaced the literals used to identify the column numbers in worksheets and arrays with constants such as:
Const ColYrEnd As Long = 3
Under my naming convention ColYrEnd = Column of Year array holding range End hence:
Years(ColYrEnd, RowYearsCrnt) = RowCvCrnt - 1
instead of Years(3, RowYearsCrnt) = RowCvCrnt - 1
This makes no difference to the compiled code but makes the source code easier to understand because you do not have to remember what columns 1, 2 and 3 hold. More importantly, if you ever have to rearrange the columns, updating the constants is the only change required. If you ever have to search through a long macro replacing every use of 2 as a column number (while ignoring any other use of 2) by 5, you will know why this is important.
Secondly, I have used:
ColValues = .Range(.Cells(1, ColSbYear), _
.Cells(RowSbLast, ColSbYear)).Value
to import column 1 to an array. The code that read the values from the worksheet now reads them from this array. Array access is much faster than worksheet access so this reduces the runtime from 1.5 seconds to .07 seconds.
The revised code is:
Sub Technique3()
Const ColCvYear As Long = 1
Const ColSbYear As Long = 1
Const ColYrYear As Long = 1
Const ColYrStart As Long = 2
Const ColYrEnd As Long = 3
Const RowSbDataFirst As Long = 2
Const RowCvDataFirst As Long = 2
Dim ColValues As Variant
Dim NumRowsUnique As Long
Dim RowCvCrnt As Long
Dim RowSbCrnt As Long
Dim RowSbLast As Long
Dim RowYearsCrnt As Long
Dim TimeStart As Double
Dim Years() As Variant
TimeStart = Timer ' Get the time as seconds since midnight to nearest .001
' of a second
With Worksheets("Simple Boundary")
RowSbLast = .Cells(Rows.Count, ColSbYear).End(xlUp).Row
ColValues = .Range(.Cells(1, ColSbYear), _
.Cells(RowSbLast, ColSbYear)).Value
' * The above statement imports all the data from column 1 as a two dimensional
' array into a Variant. The Variant is then accessed as though it is an array.
' * The first dimension has one entry per row, the second dimension has on entry
' per column which is one in this case. Both dimensions will have a lower bound
' of one even if the first row or column loaded is not one.
End With
' Count number of unique rows.
' Assume all data rows are unique until find otherwise
NumRowsUnique = UBound(ColValues, 1) - 1
For RowCvCrnt = RowCvDataFirst + 1 To UBound(ColValues, 1)
If ColValues(RowCvCrnt, ColCvYear) = ColValues(RowCvCrnt - 1, ColCvYear) Then
NumRowsUnique = NumRowsUnique - 1
End If
Next
' I mentioned earlier that I was unsure if having rows and columns in the
' convention sequence was correct. I am even less sure here where array
' ColValues has been loaded from a worksheet and the rows and columns are
' not in the conventional sequence. ReDim Years(1 To 3, 1 To NumRowsUnique)
RowYearsCrnt = 1
Years(ColYrYear, RowYearsCrnt) = ColValues(RowCvDataFirst, ColCvYear)
Years(ColYrStart, RowYearsCrnt) = RowCvDataFirst
For RowCvCrnt = RowCvDataFirst + 1 To UBound(ColValues, 1)
If ColValues(RowCvCrnt, ColCvYear) <> ColValues(RowCvCrnt - 1, ColCvYear) Then
Years(ColYrEnd, RowYearsCrnt) = RowCvCrnt - 1
RowYearsCrnt = RowYearsCrnt + 1
Years(ColYrYear, RowYearsCrnt) = ColValues(RowCvCrnt, ColCvYear)
Years(ColYrStart, RowYearsCrnt) = RowCvCrnt
End If
Next
' Record final row for final string
Years(ColYrEnd, RowYearsCrnt) = UBound(ColValues, 1)
Debug.Print "Duration: " & Format(Timer - TimeStart, "#,##0.000")
' Output diagnostics
For RowYearsCrnt = 1 To 9
Debug.Print Years(ColYrYear, RowYearsCrnt) & "|" & _
Years(ColYrStart, RowYearsCrnt) & "|" & _
Years(ColYrEnd, RowYearsCrnt) & "|"
Next
' Note that rows are now in the second dimension hence the 2 in UBound(Years, 2)
For RowYearsCrnt = UBound(Years, 2) - 9 To UBound(Years, 2)
Debug.Print Years(ColYrYear, RowYearsCrnt) & "|" & _
Years(ColYrStart, RowYearsCrnt) & "|" & _
Years(ColYrEnd, RowYearsCrnt) & "|"
Next
End Sub
Other techniques
I considered introducing other techniques but I decided they were not useful for this requirement. Also, this answer is already long enough. I have provided much for you to think about and more would just be overload. As stated above I have reduced the run time for 35,000 rows from 8 minutes to 20 seconds to 1.5 seconds to .07 seconds.
Work slowly through my macros. I have hope I have provided adequate explanation of what each is doing. Once you know a statement exists, it is generally easy to look it up so there is not too much explanation of the statements. Come back with questions as necessary.
As stated earlier in comments, ReDim Preserve is an expensive call when working with large datasets and is generally avoided. Here is some commented code that should perform as desired. Tested on a dataset with 200,000 rows, it took less than 5 seconds to complete. Tested on a dataset with 1000 rows, it took less that 0.1 seconds to complete.
The code uses a Collection to get the unique values out of column A, and then builds the array based on those unique values and outputs the results to another sheet. In your original code, there was nowhere that the resulting array was output, so I just made something up and you'll need to adjust the output section as needed.
Sub tgr()
Dim ws As Worksheet
Dim rngYears As Range
Dim collUnqYears As Collection
Dim varYear As Variant
Dim arrAllYears() As Variant
Dim arrYearsData() As Variant
Dim YearsDataIndex As Long
Set ws = ActiveWorkbook.Sheets("Simple Boundary")
Set rngYears = ws.Range("A1", ws.Cells(Rows.Count, "A").End(xlUp))
If rngYears.Cells.Count < 2 Then Exit Sub 'No data
Set collUnqYears = New Collection
With rngYears
.CurrentRegion.Sort rngYears, xlAscending, Header:=xlYes 'Sort data by year in column A
arrAllYears = .Offset(1).Resize(.Rows.Count - 1).Value 'Put list of years in array for faster calculation
'Get count of unique years by entering them into a collection (forces uniqueness)
For Each varYear In arrAllYears
On Error Resume Next
collUnqYears.Add CStr(varYear), CStr(varYear)
On Error GoTo 0
Next varYear
'Ssize the arrYearsData array appropriately
ReDim arrYearsData(1 To collUnqYears.Count, 1 To 3)
'arrYearsData column 1 = Unique Year value
'arrYearsData column 2 = Start row for the year
'arrYearsData column 3 = End row for the year
'Loop through unique values and populate the arrYearsData array with desired information
For Each varYear In collUnqYears
YearsDataIndex = YearsDataIndex + 1
arrYearsData(YearsDataIndex, 1) = varYear 'Unique year
arrYearsData(YearsDataIndex, 2) = .Find(varYear, .Cells(1), , , , xlNext).Row 'Start Row
arrYearsData(YearsDataIndex, 3) = .Find(varYear, .Cells(1), , , , xlPrevious).Row 'End Row
Next varYear
End With
'Here is where you would output your results
'Your original code did not output results anywhere, so adjust sheet and start cell as necessary
With Sheets("Sheet2")
.UsedRange.Offset(1).ClearContents 'Clear previous result data
.Range("A2").Resize(UBound(arrYearsData, 1), UBound(arrYearsData, 2)).Value = arrYearsData
.Select 'This will show the output sheet so you can see the results
End With
End Sub
As you mentioned in the comments, if you are going to continue this way you definitely need to move that redim inside the if statement:
If Not Cells(row, 1).Value = Cells(row - 1, 1).Value Then
Years = ReDimPreserve(Years, i, 3)
Years(i - 1, 3) = row - 1
Years(i, 1) = Cells(row, 1).Value
Years(i, 2) = row
i = i + 1
End If
I think this redimming multi-dimensional arrays is overkill for you. I have a few recommendations:
Ranges
I notice that you are using 2 values to represent the start of a range and end of a range (years(i,2) is the start and years(i,3) is the end). Instead why not just use an actual range?
Create a range variable called startNode and when you find the end of the range create a Range object like with Range(startNode,endNode).
Your code will look something like this:
Sub DevideData()
Dim firstCell As Range
Dim nextRange As Range
Set firstCell = Cells(2,1)
ThisWorkbook.Worksheets("Simple Boundary").Activate
TotalRows = ThisWorkbook.Worksheets("Simple Boundary").Range("A100000").End(xlUp).row
For row = 3 To TotalRows
If Not Cells(row, 1).Value = Cells(row - 1, 1).Value Then
Set nextRange = Range(firstCell, Cells(row-1,1))
Set firstCell = Cells(row,1)
End If
Next row
End Sub
1D Array
Now you do not need to store 3 values! Just an array of ranges Which you can redim like this:
Dim years() As Range
'Do Stuff'
ReDim Preserve years(1 to i)
set years(i) = nextRange
i = i + 1
Note that the only reason that ReDimPreserve was created was so that you can redim both dimensions of a 2D array (normally you can only change the second dimension). With a 1D array you can freely redim without any troubles! :)
For Each Loop
Lastly I recommend that you use a for each loop instead of a regular for loop. It makes your intentions for the loop more explicit which makes your code more readable.
Dim firstCell as Range
Dim lastUniqueValue as Variant
Dim lastCell as Range
Dim iCell as Range
Set firstCell = Cells(3,1)
lastUniqueValue = firstCell.Value
Set lastCell = ThisWorkbook.Worksheets("Simple Boundary").Range("A100000").End(xlUp)
For Each iCell in Range(firstCell, lastCell)
If iCell.Value <> lastUniqueValue Then
lastUniqueValue = iCell.Value
'Do Stuff
End If
Next
Hope this helps! :)
I need to write a program that stores names (located in the 2nd column) in an array when the name has an "X" in the 8th column, but I'm having trouble with putting names in the array. When I run it now, I get a blank value for the value in the array. After some debugging, I found out that the i value that tells which spot in the array is selected turns out to be 0, which is not what I wanted.
Here's the code:
Dim rowCount As Integer
Dim duplicateNames(100) As String
Dim duplicateNameCounter As Integer
duplicateNameCounter = 0
'Count the number of rows'
rowCount = WorksheetFunction.CountA(Range("B1:B5000"))
'Find the names with an X next to them and put them in the array'
For i = 1 To 100
If Cells(i, 8).Value = "X" Then
MsgBox ("Found a name to put in the array!")
duplicateNames(i) = Cells(i, 2).Value
duplicateNameCounter = duplicateNameCounter + 1
End If
Next i
'Show the contents of the array'
For i = 1 To duplicateNameCounter
MsgBox ("Here's the slot in the array: " & i & vbNewLine & "Here's the name: " & duplicateNames(i))
Next i
This is my first time using arrays in VBA, so I think that's where my problem is. I have a background in C++ arrays, but these don't seem too different.
Any help would be appreciated. Thanks!
You're not incrementing duplicateNameCounter the same way you're incrementing your For Each loop. I think that is the problem.
Assume you have an "X" in row 1 and also in row 100, but that the rest of the cells in your column 8 are blank (or whatever, they don't have the "X").
At the end of this block, i will be 100, and there will be names only in slots 1 and 100. HOWEVER duplicateNameCounter will only be value of 2.
For i = 1 To 100
If Cells(i, 8).Value = "X" Then
MsgBox ("Found a name to put in the array!")
duplicateNames(i) = Cells(i, 2).Value
duplicateNameCounter = duplicateNameCounter + 1
End If
Next i
So therefore when you do this, you're basically doing For i = 1 to 2, and that is going to not give you the results you expected -- because in order to display correctly the second duplicate, it would have to hit the 100th slot in the array, which it will never do.
For i = 1 To duplicateNameCounter
MsgBox ("Here's the slot in the array: " & i & vbNewLine & "Here's the name: " & duplicateNames(i))
Next i
I think that the comment from #chancea above should resolve the problem.
There were a few items that prevented successful execution of your code in excel.
Option Explicit is recommended to be used because it will force you to declare all variables and is considered a good programming practice.
Option Explicit
Public Sub asdfasdfasdf()
Dim rowCount As Integer, i As Integer
Dim duplicateNames() As String
Dim duplicateNameCounter As Integer
Setting the counter to 0 allows the array of store values to not have empty values
duplicateNameCounter = 0
Your range formula was only looking for 5000 rows of data, so it has been changed to scan the entire column to prevent missed records
'Count the number of rows'
rowCount = WorksheetFunction.CountA(Range("B:B"))
You were not searching for lower and upper case X's on the test.
'Find the names with an X next to them and put them in the array'
For i = 1 To rowCount
If Cells(i, 8).Value = "X" Or Cells(i, 8).Value = "x" Then
duplicateNameCounter = duplicateNameCounter + 1
Resizing the array was added so that the size of the array would show the number of stores found
ReDim Preserve duplicateNames(duplicateNameCounter)
Debug.Print "Found a name to put in the array! " & Cells(i, 2).Value
You were not using the duplicateNameCounter value on the duplicateNames array.
duplicateNames(duplicateNameCounter) = Cells(i, 2).Value
End If
Next i
'Show the contents of the array'
For i = 1 To duplicateNameCounter
MsgBox "Here's the slot in the array: " & i & vbNewLine & "Here's the name: " & duplicateNames(i)
Next i
End Sub
I wrote the debugging information to the immediate window to speed up running of the code, this make troubleshooting more efficient.