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.
Related
I want to check if the current destination string is located within the destination search array once the origins match up. The outcome is supposed to be all flights between any originSearch city and destinationSearch city and the corresponding flight number
I was playing with a boolean that stores all the true matches but I got confused.
Sub Matches()
Dim nFlights As Integer
Dim origin() As String
'Dim isOwned() As Boolean
Dim flightNumber() As String
Dim destination() As String
Dim iOrigin As Integer
Dim iDestination As Integer
Dim iFlight As Integer
Dim nOrigins As Integer
Dim nDestinations As Integer
Dim originSearch() As String
Dim destinationSearch() As String
Dim i As Integer
Dim x As Integer
Dim m As Integer
With wsData.Range("A1")
nFlights = Range(.Offset(1, 0), .End(xlDown)).Rows.Count
ReDim origin(1 To nFlights)
ReDim flightNumber(1 To nFlights)
ReDim destination(1 To nFlights)
'ReDim isOwned(1 To nFlights)
'stores the origin column in an array
For iOrigin = 1 To nFlights
'isOwned(iOrigin) = False
origin(iOrigin) = .Offset(iOrigin, 0).Value
Next
'stores the destination column in an array
For iDestination = 1 To nFlights
'isOwned(iDestination) = False
destination(iDestination) = .Offset(iDestination, 1).Value
Next
'stores the flight column in an array
For iFlight = 1 To nFlights
'isOwned(iFlight) = False
flightNumber(iFlight) = .Offset(iFlight, 2).Value
Next
End With
With wsData.Range("E1")
nOrigins = Range(.Offset(1, 0), .End(xlDown)).Rows.Count
nDestinations = 4 'Range(.Offset(1, 1), .End(xlDown)).Rows.Count
ReDim originSearch(1 To nOrigins)
ReDim destinationSearch(1 To nDestinations)
For i = 1 To nOrigins
originSearch(i) = .Offset(i, 0).Value
For x = 1 To nDestinations
destinationSearch(x) = .Offset(x, 1).Value
For m = 1 To nFlights
If origin(m) = originSearch(i) And destination(m) = destinationSearch(x) Then
wsData.Range("H1").Offset(i, 0).Value = originSearch(i)
wsData.Range("H1").Offset(x, 1).Value = destinationSearch(x)
wsData.Range("H1").Offset(x, 2).Value = flightNumber(m)
End If
Next m
Next x
Next i
End With
End Sub
I think you can solve the problem with this formula:
=FILTER(AllFlights;IFNA(MATCH(AllFlights[Origin];DesiredOrigin;0)*MATCH(AllFlights[Destination];DesiredDestination;0);0);)
Here:
AllFlights is the name of a table with all possible flights;
DeiredOrigin is the name of a table with origins of interest;
DeiredDestination is the name of a table with destinations of interest;
Multiplication of Matches is the matrix equivalent of the OR operator.
p.s. Instead of IFNA we can use ISNUMBER:
=FILTER(AllFlights;ISNUMBER(MATCH(AllFlights[Origin];DesiredOrigin;0)*MATCH(AllFlights[Destination];DesiredDestination;0));)
There should only be a single nested for loop at the end there.
So for each origin_dest-pair search value,
you're searching each origin_dest-pair record value.
This adds all the flight numbers of matching scenarios into an array and then puts the flight numbers into the next available column.
Also Ranges are essentially Variant() arrays, so you can just assign one to the other, instead of iterating through each value.
Option Compare Text
Sub FindFlightNumbers()
Dim orig() As Variant: orig = Range("A2:A" & Range("A2").End(xlDown).Row)
Dim dest() As Variant: dest = Range("B2:B" & Range("B2").End(xlDown).Row)
Dim flight_nums() As Variant: flight_nums = Range("C2:C" & Range("C2").End(xlDown).Row)
'Turn 2-D arrays into 1-D arrays
orig = Application.Transpose(orig)
dest = Application.Transpose(dest)
flight_nums = Application.Transpose(flight_nums)
Dim orig_search As Range: Set orig_search = Range("E2:E" & Range("e2").End(xlDown).Row)
Dim search_cell As Range, i As Integer
For Each search_cell In orig_search
Dim match_numbers() As Variant
For i = 1 To UBound(orig)
If search_cell.Value = orig(i) And search_cell.Offset(0, 1).Value = dest(i) Then
'If its the first match, init the array
If (Not match_numbers) = -1 Then
ReDim Preserve match_numbers(0)
match_numbers(0) = flight_nums(i)
Else
'Otherwise increment the array
ReDim Preserve match_numbers(UBound(match_numbers) + 1)
match_numbers(UBound(match_numbers)) = flight_nums(i)
End If
End If
Next i
'If the array had found matches, store them; comma-delimited
If Not Not match_numbers Then
search_cell.Offset(0, 2).Value = Join(match_numbers, ",")
End If
Erase match_numbers
Next search_cell
End Sub
Here's an approach using Match() directly against the search values on the worksheet:
Sub Matches()
Dim data, m As Long, rngOrigin As Range, rngDest As Range, m As Long, i As Long
'one array of all data: origin|destination|flight#
data = wsdata.Range("A2", wsdata.Cells(Rows.Count, "C").End(xlUp))
'set search ranges
Set rngOrigins = wsdata.Range("E2", wsdata.Cells(Rows.Count, "E").End(xlUp))
Set rngDest = wsdata.Range("F2", wsdata.Cells(Rows.Count, "F").End(xlUp))
'loop all source data
For m = 1 To UBound(data, 1)
'check Match() against search ranges
If Not IsError(Application.Match(data(m, 1), rngOrigins, 0)) Then
If Not IsError(Application.Match(data(m, 2), rngDest, 0)) Then
i = i + 1
wsdata.Range("H1").Offset(i, 0).Resize(1, 3) = _
Array(data(m, 1), data(m, 2), data(m, 3))
End If
End If
Next m
End Sub
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'm trying to make a new array that contains only selected values from a previous array based on a variable.
For instance, I have this as an array:
Using a selection box from a user form, I want to be able to pick item # 15 for instance (in column 1) and get a new array of just the rows that contain item # 15 (new array would be 3 rows by 9 columns).
any ideas how to do that? also allowing it to be dynamic since I want to be able to do this for different sets of Data. I'm not sure if it would be better to sort on two columns column 1 which is item # and the last column that corresponds to what sheet it is on.
Please try this code. It should be installed in a standard code module. Adjust the enumerations at the top to show where the data are (presumed to be at A2:I13). The code asks you to specify an Item to extract and will print the extracted data to an area 5 rows below the original.
Option Explicit
Enum Nws ' worksheet navigation
' modify as required
NwsFirstDataRow = 2
' columns and Array elements:-
NwsItm = 1 ' indicate column A
NwsTab = 9 ' indicate column I
End Enum
Sub Test_DataSelection()
Dim Ws As Worksheet
Dim Rng As Range
Dim Arr As Variant
Dim Itm As String
Set Ws = ThisWorkbook.Worksheets("Sheet1") ' modify as required
With Ws
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsItm), _
.Cells(.Rows.Count, NwsTab).End(xlUp))
End With
Arr = Rng.Value
Itm = InputBox("Enter a valid Item number", "Select data", 5)
Arr = SelectedData(Itm, Arr)
With Ws ' may specify another sheet here
Set Rng = .Cells(.Rows.Count, NwsItm).End(xlUp).Offset(5)
Rng.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
End With
End Sub
Function SelectedData(ByVal Itm As Variant, _
Arr As Variant) As Variant()
' Variatus #STO 21 Jan 2020
Dim Fun() As Variant
Dim Ub As Long
Dim i As Long
Dim R As Long, C As Long
On Error Resume Next
Ub = UBound(Arr)
If Err.Number = 0 Then
On Error GoTo 0
Itm = Val(Itm)
ReDim Fun(1 To UBound(Arr, 2), 1 To Ub)
For R = 1 To Ub
If Arr(R, 1) = Itm Then
i = i + 1
For C = 1 To UBound(Arr, 2)
Fun(C, i) = Arr(R, C)
Next C
End If
Next R
ReDim Preserve Fun(1 To UBound(Fun), 1 To i)
End If
SelectedData = Application.Transpose(Fun)
End Function
HerLow
A basic idea that you might be able to adapt to your needs…..to answer this …. I want to be able to pick item # 15 for instance (in column 1) and get a new array of just the rows that contain item # 15 (new array would be 3 rows by 9 columns).
Option Explicit
Sub ArrayBasedOnRowSelection()
Dim WsList As Worksheet, WsOut As Worksheet
Set WsList = ThisWorkbook.Worksheets("List"): Set WsOut = ThisWorkbook.Worksheets("Output")
Dim arrIn() As Variant, arrOut() As Variant
Let arrIn() = WsList.UsedRange
Dim Cnt As Long, strRws As String
For Cnt = 2 To WsList.UsedRange.Rows.Count
If arrIn(Cnt, 1) = "15" Then
Let strRws = strRws & Cnt & " "
Else
End If
Next Cnt
Let strRws = Left$(strRws, Len(strRws) - 1)
Dim SptStr() As String: Let SptStr() = Split(strRws, " ", -1, vbBinaryCompare)
Dim RwsT() As String: ReDim RwsT(1 To UBound(SptStr()) + 1, 1 To 1)
For Cnt = 1 To UBound(SptStr()) + 1
Let RwsT(Cnt, 1) = SptStr(Cnt - 1)
Next Cnt
Dim Clms() As Variant: Let Clms() = Evaluate("=Column(A:" & CL(WsList.UsedRange.Columns.Count) & ")") ' Evaluate("=Column(A:I)")
Let arrOut() = Application.Index(arrIn(), RwsT(), Clms())
WsOut.Cells.Clear
Let WsOut.Range("A2").Resize(UBound(arrOut(), 1), WsList.UsedRange.Columns.Count).Value = arrOut
End Sub
' http://www.excelfox.com/forum/showthread.php/1902-Function-Code-for-getting-Column-Letter-from-Column-Number?p=8824&viewfull=1#post8824
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function
If you run that macro , it will paste out an array 3 rows by as many columns as your used range in worksheet “List”, based on the selection 15 from column 1.
File: ArrayfromRowsBasedOnPreviousArray.xlsm : https://app.box.com/s/h9ipfz2ngskjn1ygitu4zkqr1puuzba1
Explanation : https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
Alan
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
I use the code hereunder to calculate max values as described in this post (vba max value of group of values). The code works great but once I have more than 65k lines I get a data type mismatch when trying to pase the array:
sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
Could somebody help me to slice the array in chunks. I have tried to get it working myself but without any luck.
Sub FillGroupsMax()
Dim lColumn As Long
Dim sht As Worksheet
Dim groupsArray As Variant 'array with all group infomation
Dim groupsSeen As Variant 'array with group infomation already seen
Application.ScreenUpdating = False 'stop screen updating makes vba perform better
Set sht = ThisWorkbook.Worksheets("import")
Set last = sht.Range("A:A").Find("*", Cells(1, 1), searchdirection:=xlPrevious) 'last cell with value in column A
lColumn = sht.Cells(1, Columns.Count).End(xlToLeft).Column
groupsArray = sht.Range(Cells(1, 1), Cells(last.Row, lColumn))
'collect all the information on the Sheet into an array
'Improves performance by not visiting the sheet
For dRow = 2 To last.Row 'for each of the rows skipping header
'check if group as already been seen
If inArrayValue(Cells(dRow, 1).Value, groupsSeen) > 0 Then
'if it has been seen/calculated attribute value
'Cells(dRow, 4).Value = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
groupsArray(dRow, lColumn) = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
Else
'if it hasn't been seen then find max
'Cells(dRow, 4).Value = getMax(Cells(dRow, 1).Value, groupsArray)
groupsArray(dRow, lColumn) = getMax(Cells(dRow, 1).Value, groupsArray, lColumn)
'array construction from empty
If IsEmpty(groupsSeen) Then
ReDim groupsSeen(0)
'groupsSeen(0) = Array(Cells(dRow, 1).Value, Cells(dRow, 4).Value)
groupsSeen(0) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
'attribute value to array
Else
ReDim Preserve groupsSeen(0 To UBound(groupsSeen) + 1)
groupsSeen(UBound(groupsSeen)) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
End If
End If
Next
sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
'reactivate Screen updating
Application.ScreenUpdating = True
End Sub
Function getMax(group As String, groupsArray As Variant, lColumn As Long) As Double
'for each in array
For n = 1 To UBound(groupsArray)
'if its the same group the Max we seen so far the record
If groupsArray(n, 1) = group And groupsArray(n, lColumn - 1) > maxSoFar Then
maxSoFar = groupsArray(n, lColumn - 1)
End If
Next
'set function value
getMax = maxSoFar
End Function
Function inArrayValue(group As String, groupsSeen As Variant) As Double
'set function value
inArrayValue = 0
'if array is empty then exit
If IsEmpty(groupsSeen) Then Exit Function
'for each in array
For n = 0 To UBound(groupsSeen)
'if we find the group
If groupsSeen(n)(0) = group Then
'set function value to the Max value already seen
inArrayValue = groupsSeen(n)(1)
'exit function earlier
Exit Function
End If
Next
End Function
You can write a helper function to use instead of Application.Index
Bonus - it will be much faster than using Index (>5x)
Sub Tester()
Dim arr, arrCol
arr = Range("A2:J80000").Value
arrCol = GetColumn(arr, 5) '<< get the fifth column
Range("L2").Resize(UBound(arrCol, 1), 1).Value = arrCol
End Sub
'extract a single column from a 1-based 2-D array
Function GetColumn(arr, colNumber)
Dim arrRet, i As Long
ReDim arrRet(1 To UBound(arr, 1), 1 To 1)
For i = 1 To UBound(arr, 1)
arrRet(i, 1) = arr(i, colNumber)
Next i
GetColumn = arrRet
End Function
EDIT - since QHarr asked about timing here's a basic example
Sub Tester()
Dim arr, arrCol, t, i as long
arr = Range("A2:J80000").Value
t = Timer
For i = 1 to 100
arrCol = GetColumn(arr, 5) '<< get the fifth column
Next i
Debug.print Timer - t '<<# of seconds for execution
End Sub
Below, whilst not as tidy as could be, is a way to process an array in chunks and Index to access a column and write out to the sheet.
I populated two columns (A:B) with data. Both had 132,000 rows, populated incrementally, with values from 1 to 132,000 in each column for my test run.
You can fiddle with cutOff to get the chunk size just below the point where the fail happens.
The code below is simply to demonstrate the principle of looping in batches, upto the set cutoff in each batch, until all rows have been processed.
Option Explicit
Public Sub WriteArrayToSheet()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set sht = wb.Worksheets("Sheet1") 'change as appropriate
Dim myArr() 'dynamic array
myArr = sht.Range("A1").CurrentRegion.Value 'you may want a more robust method
Dim cutOff As Long 'the max value - what ever it is before error occurs
cutOff = 1000
Dim totalRows As Long 'total rows in array read in from sheet
totalRows = UBound(myArr, 1)
Dim totalArraysNeeded As Long
'Determine how many lots of cutOff chunks there are in the total number of array rows
totalArraysNeeded = Application.WorksheetFunction.Ceiling(totalRows / cutOff, 1)
Dim rotations As Long 'number of times to loop original array to handle all rows
Dim rowCountTotal As Long
Dim rowCount As Long
Dim tempArr() 'this will hold the chunk of the original array
Dim rowCounter As Long
Dim lastRow As Long
Dim nextRow As Long
Dim i As Long
Dim j As Long
Dim numRows As Long
rotations = 1
Do While rotations < totalArraysNeeded
If rotations < totalArraysNeeded - 1 Then
ReDim tempArr(1 To cutOff, 1 To UBound(myArr, 2)) 'size chunk array
numRows = cutOff
Else
numRows = totalRows - rowCountTotal
ReDim tempArr(1 To numRows, 1 To UBound(myArr, 2)) 'size chunk array
End If
For i = 1 To numRows
rowCount = 1 'rows in this chunk looped
rowCountTotal = rowCountTotal + 1 'rows in original array looped
For j = LBound(myArr, 2) To UBound(myArr, 2)
tempArr(i, j) = myArr(rowCountTotal, j)
Next j
rowCount = rowCount + 1
Next i
With sht
lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row 'Column where I am writing the sliced column out to
End With
If lastRow = 1 Then
nextRow = 1
Else
nextRow = lastRow + 1
End If
sht.Range("E" & nextRow).Resize(UBound(tempArr, 1), 1) = Application.Index(tempArr, , 1) 'write out to sheet
rotations = rotations + 1
Loop
End Sub
As #Tim suggested, the best way to slice a large array is use a loop to copy the column.
Though in your case, most of the processing time is spent on computing the maximum since your code is using a nested loop.
If you want to reduce significantly the processing time, then use a dictionary:
Sub Usage
GetMaxByGroupTo _
sourceGroups := ThisWorkbook.Range("Sheet1!A2:A100"), _
sourceValues := ThisWorkbook.Range("Sheet1!B2:B100"), _
target := ThisWorkbook.Range("Sheet1!C2")
End Sub
Sub GetMaxByGroupTo(sourceGroups As Range, sourceValues As Range, target As Range)
Dim dict As Object, groups(), values(), r As Long, max
Set dict = CreateObject("Scripting.Dictionary")
groups = sourceGroups.Value2
values = sourceValues.Value2
' store the maximum value of each group in a dictionary for an efficient lookup '
For r = Lbound(groups) to Ubound(groups)
max = dict(groups(r, 1))
If VarType(max) And values(r, 1) <= max Then Else dict(groups(r, 1)) = values(r, 1)
Next
' build and copy the result array to the sheet '
For r = Lbound(groups) to Ubound(groups)
values(r, 1) = dict(groups(r, 1))
Next
target.Resize(Ubound(groups), 1).Value2 = values
End Sub