People of the internet, I need your help! I am trying to use variant arrays to summarise a large dataset of performance data into individual scores.
I have a table with about 13000 rows and about 1500 employees to loop through.
I am not new to VBA and have used this method before so I do not know what is going wrong.
I either get a "Subscript out of Range" when the for loop exceeds the UBound of the array or a bunch of "Next without For", "End Select without Select" regardless of whether the "End" or "Next" is there or not.
Please help?
Sub createScore()
Dim loData As ListObject
Dim arrData() As Variant, arrSummary As Variant
Dim lRowCount As Long, a As Long, b As Long
Set loData = Sheets("DataMeasure").ListObjects("tbl_g2Measure")
arrData = loData.DataBodyRange
lRowCount = Range("A6").Value
Range("A8").Select
For a = 1 To lRowCount
Selection.Offset(1, 0).Select
For b = LBound(arrData) To UBound(arrData)
If arrData(b, 2) = Selection Then
Select Case arrData(b, 8)
Case "HIT"
Selection.Offset(0, 3) = Selection.Offset(0, 3) + 1
End Select
End If
Next b
Next a
Range("A8").Select
End Sub
A quick rewrite without using Select. This still isn't having any gains from the array though.
Sub createScore()
Dim loData As ListObject
Dim arrData() As Variant, arrSummary As Variant
Dim lRowCount As Long, a As Long, b As Long
Set loData = Sheets("DataMeasure").ListObjects("tbl_g2Measure")
arrData = loData.DataBodyRange
lRowCount = Range("A6").Value
' Update with correct sheet reference
With ActiveSheet.Range("A8")
For a = 1 To lRowCount
For b = LBound(arrData, 1) To UBound(arrData, 1)
If arrData(b, 2) = .Offset(a, 0).Value2 And arrData(b, 8) = "HIT" Then
.Offset(a, 3) = .Offset(a, 4)
End If
Next b
Next a
End With
End Sub
I have needed to do something similar where the user list had duplicates so I created an array of unique usernames:
Dim arr() As String
lrn = 13237 'ActiveSheet.Range("A1").Range("A1").SpecialCells(xlCellTypeLastCell).Row
ac = 0
ReDim arr(0 To ac) As String
For Each c In Range("L2:L" & lrn)
If Not IsEmpty(c.Value) Then
If Not (UBound(Filter(arr, c.Value)) > -1) Then
If ac > 0 Then ReDim Preserve arr(0 To ac)
arr(ac) = c.Value
ac = ac + 1
End If
End If
DoEvents
Next c
Related
Trying to figure out the code to make an array of all unique values in a column.
So like say from C3:C30 I want an array named divisionNames of all unique values in that range. I intend to use the array later in the code. Trying to figure out a minimalist way of doing it so I don't add like 60 more lines of code to the macro.
Would be very appreciative of any suggestions
UPDATE:
Gary's Student's response below did the trick for what I needed, but I very much appreciate the help everyone gave. Thank you. Also as a side note I am now realizing I should have added that I am using Office 365. To be honest I didn't realize it made that much of a difference, but I will remember that for future reference and again thank you for all of the help
Sub uniq()
With Application.WorksheetFunction
divisionNames = .Unique(Range("C3:C30"))
End With
End Sub
With Excel 365:
Sub uniq()
With Application.WorksheetFunction
divisionNames = .Unique(Range("C3:C30"))
End With
End Sub
EDIT#1:
This version will sort the results and put the data in column D:
Sub uniq()
With Application.WorksheetFunction
divisionNames = .Unique(Range("C3:C30"))
divisionNames = .Sort(divisionNames)
End With
u = UBound(divisionNames, 1)
Range("D3:D" & 3 + u - 1).Value = divisionNames
End Sub
Unique (Dictionary)
There is no error handling i.e. it is assumed that the range is a one-column range and that there are no error or empty values. This could be easily implemented, but you wanted it short.
1D - Function
Function getUniqueColumn1D(ColumnRange As Range)
Dim Data As Variant
Data = ColumnRange.Resize(, 1).Value
With CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data)
.Item(Data(i, 1)) = Empty
Next
ReDim Data(1 To .Count)
i = 0
Dim key As Variant
For Each key In .Keys
i = i + 1
Data(i) = key
Next key
End With
getUniqueColumn1D = Data
End Function
Sub test1D()
Dim rng As Range
Set rng = Range("C3:C30")
Dim Data As Variant
Data = getUniqueColumn1D(rng)
Debug.Print Join(Data, vbLf)
End Sub
2D - Function
Function getUniqueColumn(ColumnRange As Range)
Dim Data As Variant
Data = ColumnRange.Resize(, 1).Value
With CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data)
.Item(Data(i, 1)) = Empty
Next
ReDim Data(1 To .Count, 1 To 1)
i = 0
Dim key As Variant
For Each key In .Keys
i = i + 1
Data(i, 1) = key
Next key
End With
getUniqueColumn = Data
End Function
Sub TESTgetUniqueColumn()
Dim rng As Range
Set rng = Range("C3:C30")
Dim Data As Variant
Data = getUniqueColumn(rng)
' e.g.
Dim i As Long
For i = 1 To UBound(Data)
Debug.Print Data(i, 1)
Next i
' or:
Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
2D - Sub
Sub getUniqueColumnSub()
Dim Data As Variant
Data = Range("C3:C30")
With CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data)
.Item(Data(i, 1)) = Empty
Next
ReDim Data(1 To .Count, 1 To 1)
i = 0
Dim key As Variant
For Each key In .Keys
i = i + 1
Data(i, 1) = key
Next key
End With
' e.g.
For i = 1 To UBound(Data)
Debug.Print Data(i, 1)
Next i
' or:
Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
I have lots of recruitment data that i want to re-arrange, separate and modify using arrays. The data includes all information from 1st stage, 2nd stage and 3rd stage interview for each candidates. The idea is to separate each stage onto their own sheets (e.g. Interview 1, interview 2, interview 3). And then to also create a table that has information from all three stages for each candidate.
Firstly, i have created an array of all the data by declaring the range ("A1:AV10000") as a variant.
Then i have created a loop to loop through this data, and separate each type of event that occurs into their own arrays, using an IF function within the loop. If condition is met, create a new array and add each row that condition is met to an array.
However, i believe my arrays are being made into a 3D array and i am sure how to edit the code so that it remains 2Darray. I understand why the code may be creating 3D array (due to iterating by 1 in the loop), however i am unsure how to write code so it includes all data the row and only iterates as shown below.
e.g. currently it goes (1)(1,1),(1)(1,2) then (2)(1,1),(2)(1,2) then (3)(1,1),(3)(1,2).
I would think it would work if it was (1,1)(1,2) then (2,1)(2,2) then (3,1)(3,2). Screenshot of array format from local window
Sub AddProcessStageToArray(SourceWorksheet, RawDataArray, LastrowData, WhatStage, ArrayOutput)
For i = LBound(RawDataArray) To UBound(RawDataArray)
If RawDataArray(i, 13) = WhatStage And RawDataArray(i, 38) <> "NOK" Then
o = o + 1
'Dim ArrayName() As Variant
ReDim Preserve ArrayOutput(o)
ArrayOutput(o) = Application.Index(SourceWorksheet.Range("A1:AO" & LastrowData), i, 0)
End If
Next
End Sub
The code is being called as shown below.
Sub AddITWToArray()
Dim DataWs As Worksheet: Set DataWs = ThisWorkbook.Sheets("DATA")
Dim PoolOfWeekWs As Worksheet: Set PoolOfWeekWs = ThisWorkbook.Sheets("Pool of the week")
Dim LastrowData As Long: LastrowData = DataWs.Range("A" & Rows.Count).End(xlUp).Row
Dim LastColData As Long: LastColData = DataWs.Cells(1 & DataWs.Columns.Count).End(xlToLeft).Column
Dim LastColDataString As String: LastColDataString = Split(Cells(1, LastColData).Address, "$")(1)
Dim DataRange As Range: Set DataRange = DataWs.Range("A1:" & LastColDataString & LastrowData)
Dim DataArr As Variant: DataArr = DataWs.Range("A1:AO" & LastrowData)
'Loop through Data array, if interview process = PQL, add to table. If interview proces = 1sTITW find postion and add data, if 2ndITW find postion and highlight, if 3rd find postion and highlight
Dim PoolofWeekTableLRow As Long: PoolofWeekTableLRow = PoolOfWeekWs.Range("A" & Rows.Count).End(xlUp).Row
'PoolOfWeekWs.Rows("3:" & PoolofWeekTableLRow).ClearContents
Dim i, o As Long
Dim RowNumberArr As Variant
'Create PQLArray
Dim PQLArray() As Variant
Call AddProcessStageToArray(DataWs, DataArr, LastrowData, "Prequalification", PQLArray)
'Create 1ITWArray
Dim FirstITWArray() As Variant
Call AddProcessStageToArray(DataWs, DataArr, LastrowData, "Candidate Interview 1", FirstITWArray)
'Create 2ITWArray
Dim SecondITWArray() As Variant
Call AddProcessStageToArray(DataWs, DataArr, LastrowData, "Candidate Interview 2+", SecondITWArray)
'Create PPLArray
Dim PPLArray() As Variant
Call AddProcessStageToArray(DataWs, DataArr, LastrowData, "Candidate Interview 2*", PPLArray)
Try the next adapted function, please:
Function AddProcessStageToArray(SourceWorksheet As Worksheet, RawDataArray, LastrowData As Long, WhatStage As String) As Variant
Dim ArrayOutput() As Variant, o As Long, i As Long, j As Long
ReDim ArrayOutput(1 To UBound(RawDataArray, 2), 1 To UBound(RawDataArray, 2))
For i = LBound(RawDataArray) To UBound(RawDataArray)
If RawDataArray(i, 13) = WhatStage And RawDataArray(i, 38) <> "NOK" Then
o = o + 1
For j = 1 To UBound(RawDataArray, 2)
ArrayOutput(j, o) = RawDataArray(i, j)
Next j
End If
Next
ReDim Preserve ArrayOutput(1 To UBound(RawDataArray, 2), 1 To o)
AddProcessStageToArray = WorksheetFunction.Transpose(ArrayOutput)
End Function
It can be called in this way:
Sub testAddProcessStToArr()
Dim DataWs As Worksheet, DataArr As Variant, LastrowData As Long
Set DataWs = ThisWorkbook.Sheets("DATA")
LastrowData = DataWs.Range("A" & rows.count).End(xlUp).row
DataArr = DataWs.Range("A1:AO" & LastrowData)
Dim PQLArray() As Variant
PQLArray = AddProcessStageToArray(DataWs, DataArr, LastrowData, "Prequalification")
Dim NewSheet as Worksheet
Set NewSheet = ActiveWorkbook.Sheets.Add
NewSheet.Range("A1").Resize(UBound(PQLArray), UBound(PQLArray, 2)).Value = PQLArray
End Sub
Edited:
Please, also try the next approach, involving a preliminary counting of rows respecting the conditions criteria and then use them to fill the final array. The adapted function to be used will be the next:
Function AddProcessStageToArr(RawDataArray, arrNo As Variant) As Variant
Dim ArrayOutput() As Variant, o As Long, i As Long, j As Long
ReDim ArrayOutput(1 To UBound(arrNo) + 1, 1 To UBound(RawDataArray, 2))
For i = 0 To UBound(arrNo)
o = o + 1
For j = 1 To UBound(RawDataArray, 2)
ArrayOutput(o, j) = RawDataArray(arrNo(i), j)
Next j
Next
AddProcessStageToArr = ArrayOutput
End Function
The above function should be called in the next way:
Sub testAddProcessStToArrBis()
Dim DataWs As Worksheet, DataArr As Variant, LastrowData As Long
Dim arrNo As Variant, i As Long, k As Long
Set DataWs = ActiveSheet
LastrowData = DataWs.Range("A" & rows.count).End(xlUp).row
DataArr = DataWs.Range("A1:AO" & LastrowData).Value
ReDim arrNo(UBound(DataArr))
For i = 1 To UBound(DataArr)
If DataArr(i, 13) = "Prequalification" And DataArr(i, 38) <> "NOK" Then
arrNo(k) = i: k = k + 1
End If
Next i
ReDim Preserve arrNo(k - 1)
Dim PQLArray() As Variant
PQLArray = AddProcessStageToArr(DataArr, arrNo)
Dim NewSheet As Worksheet
Set NewSheet = ActiveWorkbook.Sheets.Add(After:=DataWs)
NewSheet.Range("A1").Resize(UBound(PQLArray), UBound(PQLArray, 2)).Value = PQLArray
End Sub
The same function must be used, but changing "Prequalification" with "Candidate Interview x" and rebuild arrNo for each case...
I'm trying to create an array with only unique values (Signal Names). For example my spreadsheet looks like this
Voltage
Voltage
Voltage
Current
Current
Current
etc....
I've got 32 signals however, I want this to work even if I don't know I have 32 signals explicitly i.e. 17 signals.
Signals("Voltage", "Current", "Etc....")
IN THE CODE BELOW
I realize I'm trying to ReDim an array within a loop and that's the problem. I'm just not able to think of another way of doing this. I would prefer to keep it as an array problem and not a dictionary or collection problem for now.
Public Sub Signals()
Dim myArray() As Variant
Dim Signals() As Variant
Dim element As Variant
Dim intA As Integer
WsName = ActiveSheet.Name
intRows = Sheets(WsName).Range("B2", Sheets(WsName).Range("B" & Sheets(WsName).Rows.Count).End(xlUp)).Rows.Count
intRows = intRows + 1
ReDim Signals(1)
Signals(1) = Sheets(WsName).Cells(4, 2).Value
For intA = 4 To intRows
For Each element In Signals()
If element <> Sheets(WsName).Cells(intA, 2) Then
ReDim Signals(UBound(Signals) + 1) 'This throws the error
Signals(UBound(Signals)) = Sheets(WsName).Cells(intA, 2).Value
End If
Next element
Next
End Sub
How the code doesn't work - RunTime Error '10' Array is temporarily fixed or locked.
I posted a solution to this issue using arrays in a similar question a couple days ago - using column B for your case, this would do the trick.
Aside from this solution, you have several problems in your current code - you're testing against each individual element in your current array without checking them all first, you're not using ReDim Preserve, and you need (0 to 0), not just a single (0) or (1). You're also naming your subroutine "Signals" while attempting to declare a variable "Signals" in the subroutine as well... That'll cause all kinds of issues.
Sub Test()
Dim list() As Variant
Dim inlist As Boolean
Dim n As Long, i As Long, j As Long, endrow As Long, colnum As Long
ReDim list(0 To 0)
inlist = False
j = 0
colnum = 2 'Column B in this case
endrow = Cells(Rows.Count, colnum).End(xlUp).Row
For n = 1 To endrow
For i = 0 To UBound(list)
If list(i) = Cells(n, colnum).Value Then
inlist = True
Exit For
End If
Next i
If inlist = False Then
ReDim Preserve list(0 To j)
list(j) = Cells(n, colnum).Value
j = j + 1
End If
inlist = False
Next n
For i = 0 To UBound(list)
Debug.Print list(i)
Next i
End Sub
Even simpler solution thanks to #user10829321's suggestions:
Sub Test()
Dim list() As Variant
Dim n As Long, i As Long, j As Long, endrow As Long, colnum As Long
ReDim list(0 To 0)
j = 0
colnum = 2 'Column B in this case
endrow = Cells(Rows.Count, colnum).End(xlUp).Row
For n = 1 To endrow
If IsError(Application.Match(Cells(n, colnum).Value, list, 0)) Then
ReDim Preserve list(0 To j)
list(j) = Cells(n, colnum).Value
j = j + 1
End If
Next n
For i = 0 To UBound(list)
Debug.Print list(i)
Next i
End Sub
An optional, if perhaps unwanted, solution using a scripting dictionary to give an array.
Public Function Signals(ByRef this_worksheet_range As excel.Range) As Variant()
Dim myArray() As Variant
Dim element As Variant
Dim interim_dic As Scripting.Dictionary
myArray = this_worksheet_range.values2
Set interim_dic = New Scripting.Dictionary
For Each element In myArray
If Not interim_dic.Exists(element) Then
interim_dic.Add Key:=element, Item:=element
End If
Next
Signals = interim_dic.Items
End Function
In Excel, I have an array from A1 to P30 filled with names. Some cells have the same name (duplicate).
Is there a formula possible to list all the content of this array in one single column (on another sheet)? This list must gather only unique name (no duplicate).
Thanks in advance.
Try this:
Function Unique(strRng As String) As Variant()
Dim Arr() As Variant
ReDim Arr(0)
Dim rng As Range
Dim c As Range
Dim Duplicated As Boolean
Dim i As Long
Dim j As Long
j = 0
Set rng = Range(strRng)
For Each c In rng.Cells
Duplicated = False
If c.Value <> vbNullString Then
For i = LBound(Arr) To UBound(Arr)
If c.Value = Arr(i) Then
Duplicated = True
Exit For
End If
Next i
If Not Duplicated Then
ReDim Preserve Arr(j)
Arr(j) = c.Value
j = j + 1
End If
End If
Next c
Unique = Arr
End Function 'Unique
Update
Seems you insist to using a function. Easy. Create a User Defined Function (UDF) as below:
Function Unique(rng As Range) As Variant()
Dim Arr() As Variant
ReDim Arr(0)
Dim c As Range
Dim Duplicated As Boolean
Dim i As Long
Dim j As Long
j = 0
For Each c In rng.Cells
Duplicated = False
If c.Value <> vbNullString Then
For i = LBound(Arr) To UBound(Arr)
If c.Value = Arr(i) Then
Duplicated = True
Exit For
End If
Next i
If Not Duplicated Then
ReDim Preserve Arr(j)
Arr(j) = c.Value
j = j + 1
End If
End If
Next c
Unique = Arr
' OR
'Unique = Application.Transpose(Arr) 'Use this when you want transpose your range from row to column or back.
End Function 'Unique
How to use the function?
Note that this is an array form function.
Write second code in VBA.
select the range you want to return your unique values. (In each sheet and each part of column)
Write =Unique(A1:P30) in formula bar and then press Ctrl + Shift + Enter from keyboard. (Dont press Enter only)
Now, you have a formula that return you unique values of a range as you said.
I prefer to use a Collection or Dictionary to check for duplicates.
In this example I use an ArrayList
Sub ProcessNames()
Dim v As Variant
Dim list As Object
Set list = CreateObject("System.Collections.ArrayList")
With Worksheets("Sheet1")
For Each v In .Range("A1:P30").Value
If Not list.Contains(v) Then list.Add v
End With
'1 Dimensional 0 Based Array which will span 1 Row
v = list.ToArray
'2 Dimensional 1 Based Array that will span 1 Column
v = WorksheetFunction.Transpose(v)
End Sub
I have 3 arrays of data, that are filled by reading off of an excel sheet, some of the points of data are missing and as such have just been entered into excel as "NA" so I want to look through my array and find each instance of these NA's and remove them from the array since the information is useless. I need to update all three arrays at the same time.
Sub group_data()
Dim country(), roe(), iCap() As String
Dim i As Integer
For i = 1 To 3357
country(i) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("C1").Offset(i, 0)
roe(i) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("AP1").Offset(i, 0)
iCap(i) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("BM1").Offset(i, 0)
Next i
End Sub
So if I find a "NA" as one of the values in roe or iCap I want to get rid of that piece of data in all there arrays.
Note: I have written this code in Notepad.
Let me know if you face any problem with this.
Sub group_data()
dim totalRows as integer
dim rowNum as integer
dim rowsWithoutNA as integer
dim c1Range as Range
dim ap1Range as Range
dim bm1Range as Range
set c1Range = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("C1")
set ap1Range = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("AP1")
set bm1Range = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("BM1")
Dim country(), roe(), iCap() As String
Dim i As Integer
totalRows = 3357
redim country(totalRows)
redim roe(totalRows)
redim iCap(totalRows)
For i = 0 To (totalRows - 1)
rowNum = rowNum + 1
roe(rowsWithoutNA) = ap1Range.Offset(rowNum, 0).Text
iCap(rowsWithoutNA) = bm1Range.Offset(rowNum, 0).Text
if (WorksheetFunction.IsNA(roe(rowNum)) _
OR WorksheetFunction.IsNA(iCap(rowNum))) = False Then
' use the following condition, if NA is written in text
'if (trim(roe(rowNum)) = "NA" OR trim(iCap(rowNum)) = "NA") Then
country(rowsWithoutNA) = c1Range.Offset(rowNum, 0)
rowsWithoutNA = rowsWithoutNA + 1
end if
Next i
redim preserve country(rowsWithoutNA )
redim preserve roe(rowsWithoutNA )
redim preserve iCap(rowsWithoutNA )
end sub
I wouldn't even include the "NA" in the first place when building the arrays. Here's your code, but changed to not include "NA".
Sub group_data()
Dim country() As String
ReDim country(0)
Dim roe() As String
ReDim roe(0)
Dim iCap() As String
ReDim iCap(0)
Dim i As Integer
Dim increment1, increment2, increment3 As Integer
increment1 = 0
increment2 = 0
increment3 = 0
For i = 1 To 3357
If Not Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("C1").Offset(i, 0) = "NA" Then
ReDim Preserve country(UBound(country) + 1)
country(increment1) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("C1").Offset(i, 0)
increment1 = increment1 + 1
End If
If Not Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("AP1").Offset(i, 0) = "NA" Then
ReDim Preserve roe(UBound(roe) + 1)
roe(increment2) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("AP1").Offset(i, 0)
increment2 = increment2 + 1
End If
If Not Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("BM1").Offset(i, 0) = "NA" Then
ReDim Preserve iCap(UBound(iCap) + 1)
iCap(increment3) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("BM1").Offset(i, 0)
increment3 = increment3 + 1
End If
Next i
End Sub
Just to be clear, I am assuming you have a list of countries in Range C1 and then associated roe and iCap values in ranges AP1 and BM1. The issue that some of the roe and iCap entires are missing and have been entered as 'NA'. You would like to create arrays that contain only countries where there is both an roe and iCap value.
Firstly, using Redim Preserve is an 'expensive' operation and will impact efficiency of code.
Secondly, as an aside, using syntax as in your code (below) will only set the final variable to String. The first two will be created as variable type Variant:
Dim country(), roe(), iCap() As String
This code should be written as:
Dim country() as String, roe() as String, iCap() As String
In terms of your issue, my approach would be as follows:
Sub FillArrays()
'Define arrays
Dim countryArray() As String, roeArray() As Variant, iCapArray() As Variant
'Get total number of countries
Dim totalRows As Long
totalRows = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("C1").End(xlDown).Row
'Define array size based on totalRows
ReDim countryArray(totalRows - 1)
ReDim roeArray(totalRows - 1)
ReDim iCapArray(totalRows - 1)
'Define missing data text
Dim missingData As String
missingData = "NA"
Dim iArray As Long
iArray = 0
With Workbooks("restcompfirm.xls").Worksheets("Sheet1")
'Loop through each row and check if either roe or iCap are set to 'NA'
For cl = 1 To totalRows
If Trim(.Range("AP" & cl)) <> missingData Then
If Trim(.Range("BM" & cl)) <> missingData Then
countryArray(iArray) = .Range("C" & cl)
roeArray(iArray) = .Range("AP" & cl)
iCapArray(iArray) = .Range("BM" & cl)
iArray = iArray + 1
End If
End If
Next cl
End With
End Sub
Hope this helps.