Related
The function is taking Sheet as string. I dont see which worksheet the sheet is referring to. Otherwise with slight modification i could have redirected to the worksheet i wanted. While debugging, i see the error of "subscript out of range"
Function TextFileInfoArrayFPP(WeeksToLoad As Integer, EndingRow As Integer, StartingRow As Integer, Sheet As String) As Variant
'check and adjust for non-edited values
Sheets("REF_FPP").Visible = Visible
Sheets("REF_UPB").Visible = Visible
Dim count As Integer
count = 0
'calc the new length for the new required array
For i = 0 To EndingRow - 1
For n = 0 To WeeksToLoad - 1
If Sheets(Sheet).Cells(StartingRow + i, 9 + n).Value <> Sheets("REF_" & Sheet).Cells(StartingRow + i, 9 + n).Value Then
count = count + 1
End If
Next n
Next i
ReDim FPPArray(count, 3 - 1) As Variant
'print column names (Date, PPR Line Item, Value)
FPPArray(0, 0) = "Date"
FPPArray(0, 1) = "PPR Line Item"
FPPArray(0, 2) = "Value"
count = 1
'this is the loop through weeks
For i = 0 To WeeksToLoad - 1
'this is the loop through line item
For n = StartingRow To EndingRow
If Sheets(Sheet).Cells(n, 9 + i).Value <> Sheets("REF_" & Sheet).Cells(n, 9 + i).Value Then
'print date
FPPArray(count, 0) = Sheets(Sheet).Cells(3, 9 + i).Value
'print PPR Line item
FPPArray(count, 1) = Sheets(Sheet).Cells(n, 1).Value
'print value
FPPArray(count, 2) = Sheets(Sheet).Cells(n, i + 9).Value
count = count + 1
End If
Next n
Next i
TextFileInfoArrayFPP = FPPArray
Sheets("REF_FPP").Visible = xlHidden
Sheets("REF_UPB").Visible = xlHidden
End Function
The function is taking Sheet as string. I dont see which worksheet the sheet is referring to. Otherwise with slight modification i could have redirected to the worksheet i wanted. While debugging, i see the error of "subscript out of range"
The VBA TextFileInfoArrayFPP function is a function that appears to be used in a Microsoft Excel workbook. The function takes several arguments as input, including WeeksToLoad, EndingRow, StartingRow, and Sheet. The function performs several operations on data contained in Excel spreadsheets and returns an array of output values.
Specifically, the function performed if the cells in a range of enabled cells on a given worksheet are different from the corresponding cells on another worksheet. If the cell values are different, the function adds those values to a table as rows with three columns: "Date", "PPR Line Item", and "Value". The function then returns this array as output.
I have two tables in Excel, one with categories and listings, and another with points based on the category and listing threshold. It goes as follows:
Categories table:
ID
CATEGORY
LISTINGS
Points
001
A
56
002
C
120
003
A
4
004
B
98
Points table:
Category
tier1
tier2
tier3
A
Tier 1
Tier 2
Tier 3
Range
1-30
31-90
91-
Points
10
20
30
B
Tier 1
Tier 2
Tier 3
Range
1-25
26-100
101-
Points
10
20
30
C
Tier 1
Tier 2
Tier 3
Range
1-40
41-80
81-
Points
10
20
30
I started with an INDEX MATCH formula pointing at the points:
=INDEX(Points!A1:D11, MATCH(Categories!B2, Points!A1:A11, 0)+2)
--> the +2 is to get the points directly
I also though of evaluating the thresholds with this formula:
=IF(Categories!C2 >= NUMBERVALUE(LEFT(Points!D3, FIND("-",Points!D3)-1)),Points!D4, IF(Categories!C2 >=NUMBERVALUE(LEFT(Points!C3, FIND("-",Points!C3)-1)),Points!C4, Points!B4))
I thought that the else if the if would make it faster.
Could someone help me populate the Points column in the Categories table? VBA code is also acceptable. The tables are in different sheets.
José, your original Match formula is the right starting place. It locates the particular sub-table to do a further lookup on. But in order to make this formula a whole lot simpler, can we change the ranges (1-30, 31-90, 91-) to have just their starting points (1, 31, 91)? If we do that simple change then we can use the approximate lookup feature of HLookup to easily and compactly specify the Lookup:
=HLookup($C2,Offset(Points!$A$1,Match($B2,Points!$A:$A,0),1,2,3),2,True)
In the middle of this formula you can see your original Match function to locate the correct sub-table based on the category. We need to feed that start point to OFFSET() to create a table range useful to the HLookup. Offset takes an anchor cell reference (top left of the Points table), number of rows to count down from there (result of the Match), number of columns to the right (1), the number of rows in the range (2), and the number of columns in the range (3).
The Hlookup is just like a VLookup, but for tables arranged left-to-right not top-to-bottom. The True as the last parameter is very important as it tells HLookup to use the range lookup instead of an exact match.
A slightly verbose formula which takes the data as originally formatted (using Excel 365 Let):
=LET(ranges,INDEX(Points!B$2:D$12,MATCH(B2,Points!A$1:A$12,0),0),
leftRanges,VALUE(LEFT(ranges,FIND("-",ranges)-1)),
points,INDEX(Points!B$2:D$12,MATCH(B2,Points!A$1:A$12,0)+1,0),
INDEX(points,MATCH(C2,leftRanges)))
As it's urgent this is what I got but I cannot continue before tomorrow. Assuming you can at least put the tiers next to the category (A on same line as tiers) this will get you the first tier. You just need to copy the whole formula in the "nextCol", with minor modifications to get the next tiers.
if you really cannot change the source you need to add an additional offset in the first match.
=IF(AND(D1>NUMBERVALUE(LEFT(INDIRECT("B"&MATCH(E1,A:A,0)),FIND("-",INDIRECT("B"&MATCH(E1,A:A,0)))-1)),D1<NUMBERVALUE(RIGHT(INDIRECT("B"&MATCH(E1,A:A,0)),2))),INDEX(B:D,MATCH(E1,A:A,0)+1,1),"nextCol")
Option Explicit
Sub Score()
Dim wsP As Worksheet, wsC As Worksheet, dict
Dim iLastRow As Long, r As Long, i As Long, j As Integer
Dim sCat As String, iListing As Integer
Dim data, ar
Set wsP = Sheets("Points")
Set wsC = Sheets("Categories")
Set dict = CreateObject("Scripting.Dictionary")
iLastRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row
data = wsC.Range("A1:D" & iLastRow).Value2
' category to row lookup
For i = 1 To UBound(data)
If data(i, 1) = "Range" Then
dict.Add Trim(data(i - 1, 1)), i ' range
End If
Next
' scan points
iLastRow = wsP.Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To iLastRow
sCat = Trim(wsP.Cells(r, "B"))
iListing = wsP.Cells(r, "C")
If dict.exists(sCat) Then
i = dict(sCat)
For j = 4 To 2 Step -1
ar = Split(data(i, j), "-") ' lower-upper limit
If iListing >= ar(0) Then ' check lower limit
' update points
wsP.Cells(r, "D") = data(i + 1, j) ' points
Exit For
End If
Next
Else
MsgBox "No match '" & sCat & "'", vbCritical, "ERROR row " & r
End If
Next
MsgBox "done"
End Sub
Please, try the next code. It uses arrays and should be very fast, working only in memory. Please use your sheets when setting shC and shP as your real sheets. I only use the active sheet and the next one for testing reason:
Sub GetPoints()
Dim shC As Worksheet, shP As Worksheet, lastRC As Long, lastRP As Long, arrBC, arrP, arrPP, arrFin
Dim i As Long, j As Long, p As Long, k As Long
Set shC = ActiveSheet 'use here your Categories sheet
Set shP = shC.Next 'use here your Points sheet
lastRC = shC.Range("A" & shC.rows.count).End(xlUp).row
lastRP = shP.Range("A" & shP.rows.count).End(xlUp).row
arrBC = shC.Range("B2:C" & lastRC).Value 'put the range B:C in an array
arrP = shP.Range("A2:D" & lastRP).Value 'put all the range in an array
ReDim arrFin(1 To UBound(arrBC), 1 To 1) 'redim the array to keep processed values
For i = 1 To UBound(arrBC) 'iterate between Categ array elements:
For j = 1 To UBound(arrP) 'iterate between Points array elements:
If arrP(j, 1) = arrBC(i, 1) Then 'if Category is found:
For p = 2 To 4 'iterate between the next array row elements
arrPP = Split(arrP(j + 1, p), "-") 'split the element by "-" to determine the interval
If arrPP(1) <> "" Then 'for the tier3 case:
If arrBC(i, 2) >= CLng(arrPP(0)) And arrBC(i, 2) <= CLng(arrPP(1)) Then
k = k + 1
arrFin(k, 1) = arrP(j + 2, p): j = j + 2: Exit For 'place the value in the final array and exit iteration
End If
Else 'for the tier1 and tier2 cases:
If arrBC(i, 2) >= CLng(arrPP(0)) Then
k = k + 1
arrFin(k, 1) = arrP(j + 2, p): j = j + 2: Exit For 'place the value in the final array and exit iteration
End If
End If
Next p
End If
Next j
Next i
'drop the final array result at once:
shC.Range("D2").Resize(UBound(arrFin), 1).Value = arrFin
End Sub
I have a large table, sometimes with hundreds of rows.
This table is generated by another application that exports to excel.
One column has the heading "Adjusted Price".
I want all the rows in this column to contain a formula (presently they're all 0's).
I want to automate this process because the table gets regenerated all the time.
This column may not always be in the same place. So I need a macro that can find this column ("Adjusted Price") and then fill all the cells in that column with a formula (with the exception of the first row of course).
Can this be done?
Thanks in advance :)
Your homework is to figure out how to plug it in!
Option Explicit
Sub setAdjustedPrice()
Dim column As Integer
Dim adjustedPriceColumn As String
Dim found As Boolean
Dim rowCount As Long
column = 1
rowCount = 1
Do While Range(FncAlphaCon(column) & rowCount).Value <> "" And found = False
If (Range(FncAlphaCon(column) & rowCount).Value = "Adjusted Price") Then
found = True
adjustedPriceColumn = FncAlphaCon(column)
Else
column = column + 1
End If
Loop
If found = True Then
Do While rowCount < ActiveSheet.UsedRange.Rows.count
rowCount = rowCount + 1
Range(adjustedPriceColumn & rowCount) = "YOUR FORMULA"
Loop
Else
MsgBox ("'Adjusted Price' column not found, cannot continue.")
End If
End Sub
Private Function FncAlphaCon(aNumber As Integer) As String
' Fixed version 27/10/2011
Dim letterArray As String
Dim iterations As Integer
letterArray = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
If aNumber <= 26 Then
FncAlphaCon = (Mid$(letterArray, aNumber, 1))
Else
If aNumber Mod 26 = 0 Then
iterations = Int(aNumber / 26)
FncAlphaCon = (Mid$(letterArray, iterations - 1, 1)) & (Mid$(letterArray, 26, 1))
Else
'we deliberately round down using 'Int' as anything with decimal places is not a full iteration.
iterations = Int(aNumber / 26)
FncAlphaCon = (Mid$(letterArray, iterations, 1)) & (Mid$(letterArray, (aNumber - (26 * iterations)), 1))
End If
End If
End Function
What I am trying to achieve
I have two sheets: 'dashboard' and 'temp calc'.
Dashboard has all employee details and range "N1" "N2" contain dates.
Now a macro populates employee data and generates a daywise calendar as shown in the following image
'temp calc' has their project details with start date end date.(the date that do not fall between n1 and n2 dates from dashboard sheet are deleted here).
So now referencing their empid from dashboard sheet, and using the first day populated in dashboard sheet i loop through the emp id in temp calc sheet and return a count for the number of projects a employee is currently working on for the particular day. as shown in the following image.
how I achieve this:
the code.....
Option Explicit
Sub Count()
' x= no of columns(dashboard calender)
' y= no of rows(dashboard emp id)
' z= no of rows(temp calc sheet emp id)
Application.ScreenUpdating = False
'Clear calender data
Range("Q4").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
Dim i, j, k, l, d, x, y, z, Empid As Long
Dim currentdate, startdate, enddate As Date
x = (Range("n2") - Range("n1")) + 1
y = Application.WorksheetFunction.counta(Range("A:A")) - 1
z = Application.WorksheetFunction.counta(Worksheets("Temp Calc").Range("A:A")) - 1
For i = 1 To y Step 1 'To loop through the emp_id in dashboard.
For j = 1 To x Step 1 'To loop through the calender in dashboard daywise.
d = 0
For k = 1 To z Step 1 'To loop through the emp_id i temp calc sheet.
Empid = ActiveSheet.Cells(i + 3, 1).Value
currentdate = Cells(3, 16 + j).Value
startdate = Worksheets("Temp calc").Cells(k + 1, 3).Value
enddate = Worksheets("Temp calc").Cells(k + 1, 4).Value
If (Worksheets("Temp calc").Cells(k + 1, 1).Value) = Empid Then
If (currentdate >= startdate) And (currentdate <= enddate) Then 'To check whether the first column date falls within the project start and end date
d = d + 1
End If
End If
Next
Worksheets("Dashboard").Cells(i + 3, j + 16) = d
Next
Next
Range("q4").Select
Application.ScreenUpdating = True
End Sub
My problem: The code does the job,but I have two problems.
It is too slow
Sometimes the workbook will say not responding and won't do the work.I've checked it does not work in the background. I left the program running overnight and it went into not responding.
Possible solutions:
using two arrays: one array to store empid in dashboard,second array to store calendar generated in dashboard. and then compare it with data from temp calc sheet and return a count into array number 2 and write it back
the problem is I've just started reading about arrays and I am still learning
I am open to possible alternatives:
cheers,
mathew
There are several built in functions that will do this quite efficiently. There are just a couple I will list here:
Use Autofilter to select only a particular set of data (e.g. autofilter on an employee, or autofilter on date range etc) - then you can step through just the elements belonging to that employee
sort on employee - then you only step through valid employee IDs, and when you get to the next employee you start the next loop
use a pivot table to do the entire thing for you: create the table
with employee ID down the left side, date on top, and use "count" as the function being evaluated. You can use the Filter option in the pivot table to get this down to the date range you want - or you can autofilter the data in the employee table to the range you want before computing the pivot table
Any of these should make your code plenty fast - my personal preference is option 3... And if you don't like the layout of option 3, and you can't make it "just so", then create the pivot table in a hidden sheet and copy the data from there to the sheet you want.
As an aside - doing things like COUNTA("A:A" is likely quite slow since this means looking at all 1.5 million cells in the column. If the rows are contiguous you should be able to do something like:
COUNTA(RANGE("A1", [A1].End(xlDown)))
or (if not contiguous)
numRows = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
COUNTA(RANGE("A1", [A1].OFFSET(numRows,0)))
This works for me..... Hope it will be helpful for someone else with the same problem..
A big thank you to everyone who helped me with this and also for everybodys suggestions and answers.... :)
Sub assginment_count()
Dim a, i As Long, ii As Long, dic As Object, w, e, s
Dim StartDate As Date, EndDate As Date
Set dic = CreateObject("Scripting.Dictionary")
' use dic as a "mother dictionary" object to store unique "Employee" info.
dic.CompareMode = 1
' set compare mode to case-insensitive.
a = Sheets("temp calc").Cells(1).CurrentRegion.Value
' store whole data in "Temp Calc" to variable "a" to speed up the process.
For i = 2 To UBound(a, 1)
' commence loop from row 2.
If Not dic.exists(a(i, 1)) Then
Set dic(a(i, 1)) = CreateObject("Scripting.Dictionary")
' set child dictionary to each unique "Emp Id"
End If
If Not dic(a(i, 1)).exists(a(i, 3)) Then
Set dic(a(i, 1))(a(i, 3)) = _
CreateObject("Scripting.Dictionary")
' set child child dictionary to each unique "Startdt" to unique "Emp Id"
End If
dic(a(i, 1))(a(i, 3))(a(i, 4)) = dic(a(i, 1))(a(i, 3))(a(i, 4)) + 1
' add 1(count) to a unique set of "Emp Id", "Startdt" and "Finishdt", so that it enables to count as
' different match even if multiple same unique set of "Emp Id", "Startdt" and "Finishdt" appears.
Next
With Sheets("dashboard")
StartDate = .[N1].Value: EndDate = .[N2].Value
With .Range("a3").CurrentRegion.Resize(, .Rows(3).Find("*", , , , xlByRows, xlPrevious).Column)
' finding the data range, cos you have blank column within the data range.
.Columns("q").Resize(.Rows.count - 3, .Columns.count - 16).Offset(3).Value = 0
' initialize the values in result range set to "0".
a = .Value
' store whole data range to an array "a"
For i = 4 To UBound(a, 1)
' commence loop from row 4.
If dic.exists(a(i, 1)) Then
' when mother dictionary finds "Employee"
For Each e In dic(a(i, 1))
' loop each "Startdt"
For Each s In dic(a(i, 1))(e)
' loop corresponding "Finishdt"
If (e <= EndDate) * (s >= StartDate) Then
' when "Startdt" <= EndDate and "Finishdt" >= StartDate
For ii = 17 To UBound(a, 2)
' commence loop from col.Q
If (a(3, ii) >= e) * (s >= a(3, ii)) Then
' when date in the list matches to date between "Startdt" and "Finishdt"
a(i, ii) = a(i, ii) + dic(a(i, 1))(e)(s)
' add its count to corresponding place in array "a"
End If
Next
End If
Next
Next
End If
Next
.Value = a
' dump whole data to a range.
End With
End With
End Sub
First time poster and new to programming in general. I have a project in which i have to build a financial model to mine for data in excel. I have succeeded in building said model on VBA. I have ran tests on 3,000 line dataset and it was successful. I will briefly explain what it does.
I track a given stock on a given day on multiple exchanges. I download the data (roughly 935,000 lines) The first step is copy all the data for a given exchange (roughly 290,000) onto a new sheet (this takes roughly 8min), then I create a new column to log the bid ask spread (12secs), the next step is what Im having trouble with, I basically rank each line of data twice, one column for Bid size and one column for Ask size. I created a function which uses excel Percentile function and ranks based on where the given bid and ask size lands. As of right now, I have been running the Macro for the last 35min and has yet to execute. I cant attempt the other macros since each macro depends on the previous one.
So my basic issue is that since my data set is large, my model keeps crashing.The code seems to be fine when working with the test data, and it doesn't throw any errors when I run the program, but with the larger data set it just crashes. Does anyone have any suggestions? Is this normal with such large amounts of data?
Thanks in advance.
Sham
Here is the sub and function thats giving me the trouble, the sub takes in the required inputs to run the function and then pops into the assigned cell. The code is suppose to repeat the process for three separate sheets. For now, Id like it to work on one sheet, hence used the comments to not include the loop
Sub Bucketting()
Dim firstRow As Long
Dim lastRow As Long
Dim counter As Long
Dim bidRange As Range
Dim offerRange As Range
Dim bidScroll As Range
Dim offerScroll As Range
Dim Ex As String
Dim i As Integer
'For i = 1 To 1 Step 1 'Sheet Selection Process
' If i = 1 Then
' Ex = "Z"
' ElseIf i = 2 Then
' Ex = "P"
' Else
' Ex = "T"
' End If
Sheets("Z").Select 'Sheet selected
With ActiveSheet
firstRow = .UsedRange.Cells(1).Row + 1
lastRow = .UsedRange.Rows.Count
Set bidRange = .Range("F2:F" & lastRow)
Set offerRange = .Range("G2:G" & lastRow)
For counter = lastRow To firstRow Step -1
Set bidScroll = .Range("F" & counter)
Set offerScroll = .Range("G" & counter)
With .Cells(counter, "J")
.Value = DECILE_RANK(bidRange, bidScroll)
End With
With .Cells(counter, "K")
.Value = DECILE_RANK(offerRange, offerScroll)
End With
Next counter
End With
Range("J1").Select
ActiveCell = "Bid Rank"
ActiveCell.Offset(0, 1) = "Offer Rank"
'Next i
End Sub
Function DECILE_RANK(DataRange, RefCell)
'Credit: BJRaid
'DECILE_RANK(The Range of data)
'Declares the function that can be called in the spreadsheet cell - enter '=DECILE_RANK(A5:A50,A5)
'Using the percentile worksheet function calculate where the 10th, 20th etc percentile of the reference range are
DEC1 = Application.WorksheetFunction.Percentile(DataRange, 0.1)
DEC2 = Application.WorksheetFunction.Percentile(DataRange, 0.2)
DEC3 = Application.WorksheetFunction.Percentile(DataRange, 0.3)
DEC4 = Application.WorksheetFunction.Percentile(DataRange, 0.4)
DEC5 = Application.WorksheetFunction.Percentile(DataRange, 0.5)
DEC6 = Application.WorksheetFunction.Percentile(DataRange, 0.6)
DEC7 = Application.WorksheetFunction.Percentile(DataRange, 0.7)
DEC8 = Application.WorksheetFunction.Percentile(DataRange, 0.8)
DEC9 = Application.WorksheetFunction.Percentile(DataRange, 0.9)
' Calculate the Decile rank that the reference cell value sits within
If (RefCell <= DEC1) Then DECILE_RANK = 1
If (RefCell > DEC1) And (RefCell <= DEC2) Then DECILE_RANK = 2
If (RefCell > DEC2) And (RefCell <= DEC3) Then DECILE_RANK = 3
If (RefCell > DEC3) And (RefCell <= DEC4) Then DECILE_RANK = 4
If (RefCell > DEC4) And (RefCell <= DEC5) Then DECILE_RANK = 5
If (RefCell > DEC5) And (RefCell <= DEC6) Then DECILE_RANK = 6
If (RefCell > DEC6) And (RefCell <= DEC7) Then DECILE_RANK = 7
If (RefCell > DEC7) And (RefCell <= DEC8) Then DECILE_RANK = 8
If (RefCell > DEC8) And (RefCell <= DEC9) Then DECILE_RANK = 9
If (RefCell > DEC9) Then DECILE_RANK = 10
End Function
935,000 lines is a lot for excel. Like, really a lot. Barring saying using a real database, If your application is literally putting a =Percentile(...) in each cell, I would recommend Trying to use another tool for that. Perhaps something within VBA itself. More generally, use something outside of a cell - then store the result value in the cell. There is a lot of overhead in maintaining those formulas that are interdependent on 935k rows of data.
The problem is that your looping through each row individually, the Excel way is to try and work with whole ranges at once whenever possible. I would load the ranges into arrays, then modify your DECILE_RANK code to work with the items in the array.
Note that variant arrays that read ranges in are 2-D.
Here is the fully functioning code including my custom VBA array slicer. Note that it was only tested on a small dataset:
Sub Bucketting()
Dim lastRow As Long
Dim bidArray As Variant
Dim offerArray As Variant
Sheets("Sheet1").Select 'Sheet selected
With ActiveSheet
lastRow = .UsedRange.Rows.Count + 1
bidArray = .Range("F2:F" & lastRow)
offerArray = .Range("G2:G" & lastRow)
Range("J2:J" & lastRow).Value = GetArraySlice2D(DECILE_RANK(bidArray), "column", 1, 1, 0)
Range("K2:K" & lastRow).Value = GetArraySlice2D(DECILE_RANK(offerArray), "column", 1, 1, 0)
End With
Range("J1").Select
ActiveCell = "Bid Rank"
ActiveCell.Offset(0, 1) = "Offer Rank"
End Sub
Function DECILE_RANK(DataRange As Variant) As Variant
' Credit: BJRaid
' DECILE_RANK(The Range of data)
' Declares the function that can be called in the spreadsheet cell - enter '=DECILE_RANK(A5:A50,A5)
Dim DEC(0 To 10) As Variant
Dim i As Integer, j As Integer
'Using the percentile worksheet function calculate where the 10th, 20th etc percentile of the reference range are
DEC(0) = 0
For i = 1 To 9
DEC(i) = Application.WorksheetFunction.Percentile(DataRange, 0.1 * i)
Next i
DEC(10) = Application.WorksheetFunction.Max(DataRange)
' Calculate the Decile rank that the reference cell value sits within
For i = 1 To UBound(DataRange, 1)
For j = 1 To 10
If ((DataRange(i, 1) > DEC(j - 1)) And (DataRange(i, 1) <= DEC(j))) Then
DataRange(i, 1) = j
Exit For
End If
Next j
Next i
DECILE_RANK = DataRange
End Function
Public Function GetArraySlice2D(Sarray As Variant, Stype As String, Sindex As Integer, Sstart As Integer, Sfinish As Integer) As Variant
' this function returns a slice of an array, Stype is either row or column
' Sstart is beginning of slice, Sfinish is end of slice (Sfinish = 0 means entire
' row or column is taken), Sindex is the row or column to be sliced (NOTE:
' 1 is always the first row or first column)
' an Sindex value of 0 means that the array is one dimensional 3/20/09 Lance Roberts
Dim vtemp() As Variant
Dim i As Integer
On Err GoTo ErrHandler
Select Case Sindex
Case 0
If Sfinish - Sstart = UBound(Sarray) - LBound(Sarray) Then
vtemp = Sarray
Else
ReDim vtemp(1 To Sfinish - Sstart + 1)
For i = 1 To Sfinish - Sstart + 1
vtemp(i) = Sarray(i + Sstart - 1)
Next i
End If
Case Else
Select Case Stype
Case "row"
If Sfinish = 0 Or (Sstart = LBound(Sarray, 2) And Sfinish = UBound(Sarray, 2)) Then
vtemp = Application.WorksheetFunction.Index(Sarray, Sindex, 0)
Else
ReDim vtemp(1 To Sfinish - Sstart + 1)
For i = 1 To Sfinish - Sstart + 1
vtemp(i) = Sarray(Sindex, i + Sstart - 1)
Next i
End If
Case "column"
If Sfinish = 0 Or (Sstart = LBound(Sarray, 1) And Sfinish = UBound(Sarray, 1)) Then
vtemp = Application.WorksheetFunction.Index(Sarray, 0, Sindex)
Else
ReDim vtemp(1 To Sfinish - Sstart + 1)
For i = 1 To Sfinish - Sstart + 1
vtemp(i) = Sarray(i + Sstart - 1, Sindex)
Next i
End If
End Select
End Select
GetArraySlice2D = vtemp
Exit Function
ErrHandler:
Dim M As Integer
M = MsgBox("Bad Array Input", vbOKOnly, "GetArraySlice2D")
End Function
I'm not sure if this will directly address your problem, but have you considered using Application.ScreenUpdating = False? Don't forget to set it back to true once your data has processed.