I have tried below code to fill a two dimensional array in Excel VBA and I was able to get the desired results. I would like to know if there is a better way of doing this or if you foresee any technical issue once I have a significantly large size of data in real case situations. Any ideas or suggestions would be appreciated for improvement.
Sub test_selection()
' My below array is based on values contained within
' selected cells
' The purpose of using two dimensional array is to
' keep values in one column of array
' while retaining cell addresses in 2nd
' dimension to print some info in relevant cells
' offset to the selected cells
Dim anArray() As String
firstRow = Selection.Range("A1").Row
LastRow = Selection.Rows(Selection.Rows.Count).Row
colum = Selection.Columns.Column
arrSize = LastRow - firstRow
ReDim anArray(0 To arrSize, 1)
cnt = 0
For i = firstRow To LastRow
anArray(cnt, 0) = CStr(Cells(i, colum).Value2)
anArray(cnt, 1) = Cells(i, colum).Address
cnt = cnt + 1
Next i
Call TestGetFileList(anArray)
End Sub
When you have a significantly large size of data, that loop through the worksheet is going to be slow. Probably better to grab all of the data at once and reprocess it in memory.
Option Explicit
Sub test_selection()
' My below array is based on values contained within
' selected cells
' The purpose of using two dimensional array is to
' keep values in one column of array
' while retaining cell addresses in 2nd
' dimension to print some info in relevant cells
' offset to the selected cells
Dim i As Long, r As Long, c As String, anArray As Variant
With Selection
c = Split(.Cells(1).Address, "$")(1)
r = Split(.Cells(1).Address, "$")(2) - 1
anArray = .Columns(1).Cells.Resize(.Rows.Count, 2).Value2
End With
For i = LBound(anArray, 1) To UBound(anArray, 1)
anArray(i, 1) = CStr(anArray(i, 1))
anArray(i, 2) = "$" & c & "$" & i + r
Next i
TestGetFileList anArray
End Sub
Related
This question already has answers here:
Replace cells containing zero with blank
(2 answers)
Closed last year.
I need to run a macro that replace all the cells in an array that contain "0" only as value with a blank
At the same time, cells that contains 0 and other text/numbers eg. "Test01" should not be considered and left as they are
this is the code i wrote but it is really slow on a 3k row sheet
Set sht = ActiveWorkbook.Sheets("Nuova Base Dati")
sht.Activate
Set rng = Range(Range("B2"), Range("E" & sht.UsedRange.Rows.count))
For Each cell In rng
If cell.Value = "0" Then cell.Value = ""
Next
Any suggestion to make it quicker?
Please, use the next code. It uses two arrays and should be fast enough for a large range, too:
Sub ReplaceZero()
Dim shT As Worksheet, arrE, r As Long, c As Long, arrFin
Set shT = ActiveWorkbook.Sheets("Nuova Base Dati")
'place the range to be processed in an array (for faster iteration):
arrE = shT.Range(shT.Range("B2"), shT.Range("E" & shT.UsedRange.Rows.count)).Value2
ReDim arrFin(1 To UBound(arrE), 1 To UBound(arrE, 2)) 'set dimensions of the final array, keeping the processing result
For r = 1 To UBound(arrE) 'iterate between the array rows
For c = 1 To UBound(arrE, 2) 'iterate between the array columns
If arrE(r, c) = 0 Then
arrFin(r, c) = "" 'write a null string in case of zero
Else
arrFin(r, c) = arrE(r, c) 'keep the existing value, if not zero
End If
Next c
Next r
'Drop the processed array content, at once:
shT.Range("B2").resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
End Sub
The above code is fast, but in case of formula involved it will transform the formulas in their values...
This code works almost perfectly. The problem is it includes blank cells in its "matched" results. What do I need to change to make this code ignore blank cells? Below I will include an example of what is going on.
Sub MarkMatches()
Const TopLeftCell As String = "A2" ' change to match where your data are
Dim Rng As Range ' data range
Dim FirstRow As Long, FirstClm As Long
Dim Data As Variant ' original data (2-D)
Dim Arr As Variant ' data rearranged (1-D)
Dim Tmp As Variant ' working variable
Dim R As Long, R1 As Long ' row counters
Dim C As Long ' column counter
Dim Count() As String ' match counter
With Range(TopLeftCell)
FirstRow = .Row
FirstClm = .Column
End With
C = Cells(FirstRow, Columns.Count).End(xlToLeft).Column
Set Rng = Range(Cells(FirstRow, FirstClm), _
Cells(Rows.Count, FirstClm).End(xlUp).Offset(0, C - FirstClm))
Data = Rng.Value
ReDim Arr(1 To UBound(Data))
For R = 1 To UBound(Data)
ReDim Tmp(1 To UBound(Data, 2))
For C = 1 To UBound(Data, 2)
Tmp(C) = Data(R, C)
Next C
Arr(R) = Tmp
Next R
ReDim Count(1 To UBound(Arr))
For R = 1 To UBound(Arr) - 1
For R1 = R + 1 To UBound(Arr)
Tmp = 0
For C = 1 To UBound(Arr(R))
If Not IsError(Application.Match(Arr(R)(C), Arr(R1), 0)) Then
Tmp = Tmp + 1
End If
Next C
If Tmp > 0 Then ' change to suit
Tmp = Format(Tmp, "(0)") & ", "
Count(R) = Count(R) & CStr(R1 + FirstRow - 1) & Tmp
Count(R1) = Count(R1) & CStr(R + FirstRow - 1) & Tmp
End If
Next R1
Next R
For R = 1 To UBound(Count)
If Len(Count(R)) Then Count(R) = Left(Count(R), Len(Count(R)) - 2)
Next R
' set the output column here (2 columns right of the last data column)
' to avoid including this column in the evaluation
' it must be blank before a re-run
Set Rng = Rng.Resize(, 1).Offset(0, UBound(Data, 2) + 1)
Rng.Value = Application.Transpose(Count)
End Sub
Thank you #Variatus for the code and help so far!
I tried to work with your original code, but honestly I became very confused. My example below will illustrate some practices that could help (and those who may review your code later, including yourself!). So here's a list of comments:
Always use Option Explicit. Your code may already have this, but I'm listing it here for completeness sake.
Create variable names that describe what data it holds. Your code does a little of this, but some of the variable names are difficult to fit into the logic flow. My idea in coding is always to try and write self-documenting code. That way, it's nearly always clear what the code is trying to accomplish. Then I'll use comment for code blocks where it might be a bit less clear. (Don't fall into the trap of prefixing variable names with a "type" or something; it's ultimately not worth it.)
A clear description of the problem always helps. This is true not only to get help on SO, but also for yourself. My final comment to your post above, asking about the problem description really simplified everything. This includes describing what you want your output to show.
As per the problem description, you need to identify each unique item and keep track of which row you find that item so you can create a report later. A Dictionary is a perfect tool for this. Read up about how to use a Dictionary, but you should be able to follow what this block of code is doing here (even without all the previous declarations):
For Each cell In dataArea.Cells
If Not IsEmpty(cell) Then
If items.Exists(cell.Value) Then
'--- add this row to the list
rowList = items(cell.Value) & "," & cell.Row
items(cell.Value) = rowList
Else
'--- first time adding this value
items.Add cell.Value, cell.Row
End If
End If
Next cell
It's easy to see how the logic of this code follows the description of the problem. After that, it's just a matter of running through each row in the data area and checking each value on that row to see if duplicates exist on any other row. The full example solution is below for you to study and adjust to fit your situation.
Option Explicit
Sub IdentifyMatches()
Dim ws As Worksheet
Set ws = Sheet1
Dim dataArea As Range
Set dataArea = ws.Range("A1:F6")
Dim items As Dictionary
Set items = New Dictionary
'--- build the data set of all unique items, and make a note
' of which row the item appears.
' KEY = cell value
' VALUE = CSV list of row numbers
Dim rowList As String
Dim cell As Range
For Each cell In dataArea.Cells
If Not IsEmpty(cell) Then
If items.Exists(cell.Value) Then
'--- add this row to the list
rowList = items(cell.Value) & "," & cell.Row
items(cell.Value) = rowList
Else
'--- first time adding this value
items.Add cell.Value, cell.Row
End If
End If
Next cell
'--- now work through the data, row by row and make the report
Dim report As String
Dim duplicateCount As Variant
ReDim duplicateCount(1 To dataArea.Rows.Count)
Dim dataRow As Range
For Each dataRow In dataArea.Rows
Erase duplicateCount
ReDim duplicateCount(1 To dataArea.Rows.Count)
Dim rowNumber As Variant
For Each cell In dataRow.Cells
If items.Exists(cell.Value) Then
rowList = items(cell.Value)
Dim rowNumbers As Variant
rowNumbers = Split(rowList, ",")
For Each rowNumber In rowNumbers
If rowNumber <> cell.Row Then
duplicateCount(rowNumber) = duplicateCount(rowNumber) + 1
End If
Next rowNumber
End If
Next cell
report = vbNullString
For rowNumber = 1 To UBound(duplicateCount)
If duplicateCount(rowNumber) > 0 Then
report = report & rowNumber & "(" & duplicateCount(rowNumber) & ")" & ", "
End If
Next rowNumber
'--- display the report in the next column at the end of the data area
If Len(report) > 0 Then
report = Left$(report, Len(report) - 2) 'removes the trailing comma and space
dataRow.Cells(1, dataRow.Columns.Count + 1).Value = report
End If
Next dataRow
End Sub
I would like to copy data from one sheet to another.
I put the range that I want to copy into an array (LookupSource) because it's faster to work on arrays than looping through cells.
After filling my two dimensional array (LookupSource), I would like to keep only some records based on critieria (Column A = 10000), so I am trying to copy from LookupSource, the rows that fetch this criteria to the two dimensional array (DataToCopy) which will be copied to the destination sheet.
My problem is that I am not able to do that because as it seems I am not able to make a dynamic resize for the first dimension (rows) of the second array (DataToCopy).
Any Idea how to fill DataToCopy from LookupSource based on my condition ?
The error "index out of range" that I am getting is at the Line : ReDim Preserve DataToCopy(1 to j, 1 to 6)
not at first time, but on second time that I enter the For loop after the Next I
I suppose it's because the J is variable and I am not allowed to change the first dimension of the array.
How to deal with that ?
Any better Idea from what I am doing ?
to give you an example here is a small part of the sheet that I want to copy (I took only 8 rows, but in real there thousands). I want to copy only the rows that have 10000 in column A.
Here is my code
Dim LookupSource as Variant
Dim DataToCopy() As Variant
Dim i As Long
Dim j As Long
With MySheet
'MyRange is a defined name that reprensent column A, B, C, D, E, F
LookupSource = .Range(.Range("MyRange")(1, 1), .Range("MyRange")(8, 6)).Value2
j = 1
For i = LBound(LookupSource) To UBound(LookupSource)
If LookupSource(i, 1) = 10073 Then
ReDim Preserve DataToCopy(1 to j, 1 to 6)
DataToCopy(j, 1) = LookupSource(i, 1)
DataToCopy(j, 2) = LookupSource(i, 2)
DataToCopy(j, 3) = LookupSource(i, 3)
DataToCopy(j, 4) = LookupSource(i, 4)
DataToCopy(j, 5) = LookupSource(i, 5)
DataToCopy(j, 6) = LookupSource(i, 6)
j = j + 1
End If
Next i
end with
How to overcome the restrictions of ReDim Preserve in multidimensional arrays
As mentioned by #ScottCraner, a ReDim Preserve can change only the last dimension of a given (datafield) array.
Therefore trying to resize a 2-dimensional array's first dimension (="rows") will fail.
However you can overcome this inconvenience applying the relatively unknown filtering capability of Application.Index() (c.f. section [2]) and profit from the additional bonus of less loops.
Further reading: see Some pecularities of the Application.Index() function
Sub GetRowsEqual10000()
With Sheet1
Dim lastRow As Long: lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Dim rng As Range: Set rng = .Range("A2:F" & lastRow)
End With
'[1] get data
Dim data: data = rng
'[2] rearrange data via Application.Index() instead ReDim Preserve plus loops
data = Application.Index(data, ValidRows(data, Condition:=10000), Array(1, 2, 3, 4, 5, 6))
End Sub
Help function ValidRows()
Function ValidRows(arr, Condition) As Variant
'Purpose: a) check condition (e.g. values equalling 10000) and b) get valid row numbers c) in a 2-dim vertical array
ReDim tmp(1 To UBound(arr)) ' provide for 1-based 2-dim array
Dim i As Long, ii As Long
For i = 1 To UBound(arr) ' loop through 1st "column"
If arr(i, 1) = Condition Then ' a) check condition
ii = ii + 1: tmp(ii) = i ' b) collect valid row numbers
End If
Next i
ReDim Preserve tmp(1 To ii) ' resize tmp array (here the 1st dimension is also the last one:)
ValidRows = Application.Transpose(tmp) ' c) return transposed result as 2-dim array
End Function
Edit due to comment (2020-04-22)
Short hints to the most frequent use of Application.Index():
Frequently the Application.Index() function is used to
get an entire row or column array out of a 2-dim array without need to loop.
Accessing your 1-based 2-dimensional datafield array like that requires to
indicate a single row or column number and
to set the neighbour argument column or row number to 0 (zero), respectively which might result in e.g.
Dim horizontal, vertical, RowNumber As Long, ColumnNumber As Long
RowNumber = 17: ColumnNumber = 4
horizontal = Application.Index(data, RowNumber, 0)
vertical = Application.Index(data, 0, ColumnNumber)
(Addressing a single array element will be done directly, however via data(i,j)
instead of a theoretical Application.Index(data, i, j))
How to use Application.Index() for restructuring/filtering purposes:
In order to profit from the advanced possibilities of Application.Index() you
need to pass not only the array name (e.g. data), but the row|column arguments as Arrays, e.g.
data = Application.Index(data, Application.Transpose(Array(15,8,10)), Array(1, 2, 3, 4, 5, 6))
Note that the rows parameter becomes a "vertical" 2-dim array by transposition, where Array(15,8,10)
would even change the existing row order
(in the example code above this is done in the last code line within the ValidRows() function).
The columns argument Array(1,2,3,4,5,6) on the other hand remains "flat" or "horizontal" and
allows to get all existing column values as they are.
So you eventually you are receiving any data elements within the given element indices
(think them as coordinates in a graphic).
Range Lookup Function
The Code
Option Explicit
'START ****************************************************************** START'
' Purpose: Filters a range by a value in a column and returns the result '
' in an array ready to be copied to a worksheet. '
'******************************************************************************'
Function RangeLookup(LookUpValue As Variant, LookupRange As Range, _
Optional LookupColumn As Long = 1) As Variant
Dim LookUpArray As Variant ' LookUp Array
Dim DataToCopy As Variant ' DataToCopy (RangeLookup) Array
Dim countMatch As Long ' DataToCopy (RangeLookUp) Rows Counter
Dim r As Long, c As Long ' Row and Column Counters
' Check the arguments.
Select Case VarType(LookUpValue)
Case 2 To 8, 11, 17
Case Else: Exit Function
End Select
If LookupRange Is Nothing Then Exit Function
If LookupColumn < 1 Or LookupColumn > LookupRange.Columns.Count _
Then Exit Function
' Copy values of Lookup Range to Lookup Array.
LookUpArray = LookupRange
' Task: Count the number of values containing LookUp Value
' in LookUp Column of LookUp Array which will be
' the number of rows in DataToCopy Array.
' The number of columns in both arrays will be the same.
' Either:
' Count the number of values containing LookUp Value.
countMatch = Application.WorksheetFunction _
.CountIf(LookupRange.Columns(LookupColumn), LookUpValue)
' Although the previous looks more efficient, it should be tested.
' ' Or:
' ' Loop through rows of LookUpArray.
' For r = 1 To UBound(LookUpArray)
' ' Check if the value in current row in LookUp Column
' ' is equal to LookUp Value.
' If LookUpArray(r, LookupColumn) = LookUpValue Then
' ' Increase DataCopy Rows Counter.
' countMatch = countMatch + 1
' End If
' Next r
' Check if no match was found.
If countMatch = 0 Then Exit Function
' Task: Write the matching rows in LookUp Array to DataToCopy Array.
' Resize DataToCopy Array to DataToCopy Rows counted in the previous
' For Next loop and the number of columns in Lookup Array.
ReDim DataToCopy(1 To countMatch, 1 To UBound(LookUpArray, 2))
' Reset DataToCopy Rows Counter.
countMatch = 0
' Loop through rows of LookUp Array.
For r = 1 To UBound(LookUpArray)
' Check if the value in current row in LookUp Column
' is equal to LookUp Value.
If LookUpArray(r, LookupColumn) = LookUpValue Then
' Increase DataCopy Rows Counter.
countMatch = countMatch + 1
' Loop through columns of LookUp (DataToCopy) Array.
For c = 1 To UBound(LookUpArray, 2)
' Write the current value of LookUp Array to DataToCopy Array.
DataToCopy(countMatch, c) = LookUpArray(r, c)
Next c
End If
Next r
' Write values from DataToCopy Array to RangeLookup Array.
RangeLookup = DataToCopy
End Function
'END ********************************************************************** END'
You should use it e.g. like this:
Sub TryRangeLookup()
Dim LookupRange As Range
Dim DataToCopy As Variant
With MySheet
'MyRange is a defined name that reprensent column A, B, C, D, E, F
Set LookupRange = .Range(.Range("MyRange")(1, 1), _
.Range("MyRange")(8, 6)).Value2
End With
RangeLookUp 10073, DataCopy
If Not IsArray(DataToCopy) Then
MsgBox "No data found.": Exit Sub ' or whatever...
Endif
' Continue with code...
End Sub
I have the first name in column A and the last name in Column B and I need to combine them into just column A. Also not sure if I need to check this in the code but some of the cells are empty with now names. I have tried many things but they all want me to pull the two and enter them into a different or 3rd column. But I need to put them into column A.
This is the code I have and it keeps giving me the merge error.
With Worksheet
For Counter = LastRow To FirstRow Step -1
Range("BD2:BE1000").Merge Across:=True
Next Counter
End With
You can just use string concatenation here (assuming that lastrow (1000) and firstrow (2) have been set up properly in your sample code).
With Worksheet
For Counter = LastRow To FirstRow Step -1
.Range("BD" & counter).Value = .Range("BD" & counter).value & .Range("BE" & counter).value
Next Counter
End With
Concatenate (non-empty) names into one column
[1] In a first step you can assign your data range (object variable e.g. rng) to a variant 1-based 2-dim datafield array by a one liner v = rng or v = rng.Value2.
[2] In a second step you loop through all array rows and check for non-empty names concatenating these findings in the array's first columns (overwriting the original single name part).
[3] Resizing the receiving range to 1 column only (and the number of non-empty rows allows you to write the results back to sheet.
Code example
Option Explicit ' declaration head of your code module enforces declaration of variables/objects
Sub ConcatenateNames()
Dim v As Variant, rng As Range
With ThisWorkbook.Worksheets("MySheet") ' <<~~ change to your sheet name
' [1] assign names to 2-dim datafield array v
Set rng = .Range("BD2:BE1000") ' set user defined range to memory
v = rng.Value2 ' get data
' [2] loop through data
Dim i As Long, ii As Long
For i = 1 To UBound(v)
' [2a] check for non empty names
If Len(Trim(v(i, 1)) & Trim(v(i, 2))) > 0 Then
' [2b] concatenate first and last names in array v
ii = ii + 1 ' increment counter
v(ii, 1) = v(i, 1) & " " & v(i, 2)
End If
Next i
' [3] write back to sheet and resize receiving range to ii rows and 1 column
rng.Clear ' clear original data
rng.Resize(ii, 1) = v ' write names back to sheet
End With
End Sub
Further hint
Take care of the leading point . before "Range" referring to your worksheet object: Set rng = .Range("BD2:BE1000")
I am trying to find a way to:
Loop through a column (B column)
Take the values, store them in an array
Loop through that array and do some text manipulation
However, I cannot think of a way to loop through a column and take those values, storing them in an array. I have looked through Stack Overflow and google but have not found a successful solution.
In advance, thank you for your help.
Sub collectNums()
Dim eNumStorage() As String ' initial storage array to take values
Dim i as Integer
Dim j as Integer
Dim lrow As Integer
lrow = Cells(Rows.Count, "B").End(xlUp).Row ' The amount of stuff in the column
For i = lrow To 2 Step -1
If (Not IsEmpty(Cells(i, 2).Value)) Then ' checks to make sure the value isn't empty
i = eNumStorage ' I know this isn't right
Next i
If (IsEmpty(eNumStorage)) Then
MsgBox ("You did not enter an employee number for which to query our database. Quitting")
Exit Sub
End If
End Sub
This is the easiest way to get column to array:
Public Sub TestMe()
Dim myArray As Variant
Dim cnt As Long
myArray = Application.Transpose(Range("B1:B10"))
For cnt = LBound(myArray) To UBound(myArray)
myArray(cnt) = myArray(cnt) & "something"
Next cnt
For cnt = LBound(myArray) To UBound(myArray)
Debug.Print myArray(cnt)
Next cnt
End Sub
It takes the values from B1 to B10 in array and it gives possibility to add "something" to this array.
The Transpose() function takes the single column range and stores it as an array with one dimension. If the array was on a single row, then you would have needed a double transpose, to make it a single dimension array:
With Application
myArray = .Transpose(.Transpose(Range("A1:K1")))
End With
MSDN Transpose
CPearson Range To Array
Creating an Array from a Range in VBA
Just adding a variation on Vityata's which is the simplest way. This method will only add non-blank values to your array. When using your method you must declare the size of the array using Redim.
Sub collectNums()
Dim eNumStorage() As String ' initial storage array to take values
Dim i As Long
Dim j As Long
Dim lrow As Long
lrow = Cells(Rows.Count, "B").End(xlUp).Row ' The amount of stuff in the column
ReDim eNumStorage(1 To lrow - 1)
For i = lrow To 2 Step -1
If (Not IsEmpty(Cells(i, 2).Value)) Then ' checks to make sure the value isn't empty
j = j + 1
eNumStorage(j) = Cells(i, 2).Value
End If
Next i
ReDim Preserve eNumStorage(1 To j)
'Not sure what this bit is doing so have left as is
If (IsEmpty(eNumStorage)) Then
MsgBox ("You did not enter an employee number for which to query our database. Quitting")
Exit Sub
End If
For j = LBound(eNumStorage) To UBound(eNumStorage) ' loop through the previous array
eNumStorage(j) = Replace(eNumStorage(j), " ", "")
eNumStorage(j) = Replace(eNumStorage(j), ",", "")
Next j
End Sub