View Full Version : How to Loop through columns in an Array and write to a range
LucasLondon
07-27-2012, 02:59 AM
Hi,
I have a very basic question on writing results from an input Array to an output location..
Currently I have the macro below which reads data into an array from sheet2 and outputs the first column of the array into sheet3:
Sub Array_example()
Dim Rawdata
Rawdata = Worksheets("Sheet1").Range("a1:d200")
Worksheets("Sheet3").Range("a5:A205").Value = Rawdata
End Sub
I would like to amend the code so that it outputs each column of the input array interatively into the same place: ie ("Sheet3").Range("a5:A205").
So I want to do the first column (a1:a200) first, then the second column (b1:b200) and then the third etc.
I know there is various ways of doing this but what would the simpliest be without re-writing/making fewest changes to the existing code? I'm assuming I just need tp add some kind of "for each i" in array statement?
Thanks,
Lucas
Bob Phillips
07-27-2012, 04:03 AM
Sub Array_example()
Dim Rawdata
Rawdata = Worksheets("Sheet1").Range("a1:d200")
Worksheets("Sheet3").Range("a5").Resize(UBound(Rawdata, 1) - LBound(Rawdata, 1) + 1, UBound(Rawdata, 2) - LBound(Rawdata, 2) + 1).Value = Rawdata
End Sub
...outputs each column of the input array interatively into the same place: ie ("Sheet3").Range("a5:A205").
So I want to do the first column (a1:a200) first, then the second column (b1:b200) and then the third etc....
Hi Lucas,
I took your question a bit differently then Bob did. I am not sure what "interatively" means though?
If (a BIG if at this point) I am understanding at all, you may want the individual columns (or more acurately, the values therein) plunked into different places. Where? Into the first column of the 'following' sheets?
Mark
LucasLondon
07-27-2012, 04:59 AM
Hi,
Thanks Xld for the code.
Indeed by interatively I meant more in line with your understanding Mark than of Bob's whose code I have tested. It places the values of all columns of the Rawdata into sheet3 Range("A5:D19").
Whereas I wanted to place the values of each column of the array one by one into only column A of sheet3.
This is to help improve my understanding of how to better work with arrays to programe things I need to do for different VBA routines.
Thanks,
Lucas
Bob Phillips
07-27-2012, 05:03 AM
So do you mean, first column in A5:A205, second column in A206:A406, etc.
BTW, did you see my response to your Correlations question?
LucasLondon
07-27-2012, 06:18 AM
Hi Bob,
Sorry what I meant was the first column in A5:A205, and then the next column in the same place, i.e overwrite (A5:A205) with each successive column!
I've just looked at the correlation analysis based on different moving averages - thanks for the updated code. I will test out over the weekend and post my feedback.
Cheers,
L
Bob Phillips
07-27-2012, 06:25 AM
Can I ask what is the point of that? Why not just load the last column in - cut-out the middle-man?
LucasLondon
07-27-2012, 06:47 AM
Ar, well I have a couple of routines that performs some complex calculations and comparisons on a given column and then makes a decision whether to add or exclude that data/column into a model.
So in the case above, each column of data would be imported into A5:A205 and then some analysis would be done on the data and a decision made. And then it would do the next variable. But my post was illustrative only, right now I just want to understand how I would go about doing the processing part.
I know how to do it using copying and paste and for i statement commands but I want to do it using arrays instead to help develop my understanding further.
Lucas
Bob Phillips
07-27-2012, 07:04 AM
Sub Array_example()
Dim Rawdata As Variant
Dim numRows As Long
Dim i As Long
Rawdata = Worksheets("Sheet1").Range("a1:d200")
numRows = UBound(Rawdata, 1) - LBound(Rawdata, 1) + 1
For i = LBound(Rawdata, 2) To UBound(Rawdata, 2)
Worksheets("Sheet3").Range("A5").Resize(numRows).Value = Application.Transpose(Application.Transpose(Application.Index(Rawdata, 0, i)))
'do your stuff
Next i
End Sub
LucasLondon
07-27-2012, 09:04 AM
Thanks XLD.
This works as expected.
Bit confused about some elements/mechanics of how the code actually works as it seems a lot more complex than I thought it would be!
Without actually know much about it I thought naively that it would look something like:
Sub Array_Mockup()
Dim Rawdata
Rawdata = Worksheets("Sheet1").Range("a1:d200")
For i = 1 To 4
Worksheets("Sheet3").Range("a5:A205").Value = Rawdata.Range(Cells(1, i), Cells(200, i)).Value
Next i
End Sub
And in terms of the code I'm not sure that I understand how it working out the number of rows just via the follwoing line as there does not appear to be any count function etc?
numRows = UBound(Rawdata, 1) - LBound(Rawdata, 1) + 1
And not sure why any data needs to be transposed in the following line?
Worksheets("Sheet3").Range("A5").Resize(numRows).Value = Application.Transpose(Application.Transpose(Application.Index(Rawdata, 0, i)))
Anyway, I think I will need to read up more about arrays on the internet as I am clearly lacking basic knowledge in this area!
Lucas
Bob Phillips
07-27-2012, 12:49 PM
Bit confused about some elements/mechanics of how the code actually works as it seems a lot more complex than I thought it would be!
Without actually know much about it I thought naively that it would look something like:
Sub Array_Mockup()
Dim Rawdata
Rawdata = Worksheets("Sheet1").Range("a1:d200")
For i = 1 To 4
Worksheets("Sheet3").Range("a5:A205").Value = Rawdata.Range(Cells(1, i), Cells(200, i)).Value
Next i
End Sub
So I presume you tried that, and did it work?
And in terms of the code I'm not sure that I understand how it working out the number of rows just via the follwoing line as there does not appear to be any count function etc?
numRows = UBound(Rawdata, 1) - LBound(Rawdata, 1) + 1
Maybe no count, but it is doing arithmetic. It takes the lower bound of the rows dimension from the upper bound, plus 1 to be inclusive, to get that count. It is just like counting the number of rows between 11 and 20 as Row(20) - Row(11) +1.
And not sure why any data needs to be transposed in the following line?
Worksheets("Sheet3").Range("A5").Resize(numRows).Value = Application.Transpose(Application.Transpose(Application.Index(Rawdata, 0, i)))
Anyway, I think I will need to read up more about arrays on the internet as I am clearly lacking basic knowledge in this area!
Maybe the code in this form can help explain it
Sub Array_example()
Dim Rawdata As Variant
Dim ary As Variant
Dim numRows As Long
Dim i As Long
Rawdata = Worksheets("Sheet1").Range("a1:d200")
numRows = UBound(Rawdata, 1) - LBound(Rawdata, 1) + 1
For i = LBound(Rawdata, 2) To UBound(Rawdata, 2)
ary = Application.Index(Rawdata, 0, i)
ary = Application.Transpose(ary)
Worksheets("Sheet3").Range("A5").Resize(numRows).Value = Application.Transpose(ary)
'do your stuff
Next i
End Sub
The first setting of ary is getting column i of the Rawdata array. I am using the Excel INDEX function to get an array of a single column. At this stage, the intermediate array is still a 2-dimensional array, so needs more work.
The second setting of ary uses the excel TRANSPOSE function to turn it into a 1-dimensional array. This is good, but it you want to load a column, and this is a row array.
So the third setting of ary again uses the excel TRANSPOSE function to turn a row array into a column array. This is a simple load into the worksheet range.
LucasLondon
07-30-2012, 03:19 AM
Thanks XLD for explanantion of the code. This combined with some internet reading is helping to make more sense of the code.
Lucas
LucasLondon
09-25-2012, 11:46 AM
Hi,
I've been trying to expand my code requirments and have hit a brick wall. Would I need to use the same process/code setup as suggested previously if want to do something like this?
Basically I'm reading in two arrays - rawdata sheet and finaldata. I am then taking the values (strings) in the first column of the finadata array, looking them up in the first row of the rawdata array and then copy over that entire column where the match is found.
This look up process seems to work fine using the code below but right now I can only get it to return a single value from the matched column in the rawdata array instead of all of the column.
I suspect I will need to utilise the same approach as before but would be great if someone can confirm and the best way of doing it.
Thanks
Lucas
Sub A000000A1A1A_Test()
Dim Rawdata, finaldata As Variant
Rawdata = Sheets("X Variables").Range("C1:AY146").Value
finaldata = Sheets("Build-Linear").Range("AA1:AG20")
For i = 2 To 20
potvar = finaldata(i, 1) 'loops through all elements in the array
For k = 1 To UBound(Rawdata)
If Rawdata(1, k) = potvar Then
Worksheets("Sheet1").Range("A1:a146").Value = Rawdata(1, k)
End If
Next k
Next i
End Sub
Basically you need:
Sub snb()
sp = Range("C1:G30")
sn = Range("AA1:AG20")
For j = 1 To UBound(sn)
Range("A1").Resize(UBound(sp)) = Application.Index(sp, 0, Application.Match(sn(j, 1), Application.Index(sp, 1), 0))
Stop
Next
End Sub
i.e.
Lookup the respective values in AA1:AA30 in the row C1:G30 and save in column A the values of the column in range C1:C30 that has in it's first row the looked up value.
LucasLondon
09-26-2012, 05:31 AM
Thanks SNB - that appears to work as I wanted.
Instead of pasting the data into a sheet is it possible to store it as a variable that I can directly use in a function?
For example: application.worksheetfunction.Average(Variable) instead of specifying range in the formula.
So where Variable would be something like:
Variable = Resize(UBound(Rawdata)) = Application.Index(Rawdata, 0, Application.Match(Varlist(j, 1), Application.Index(Rawdata, 1), 0))
Thanks,
Lucas
Latest code
Sub A00snb121()
Rawdata = Sheets("X Variables").Range("C1:AY146") 'Raw data Variables
Varlist = Sheets("Build-Linear").Range("AA1:AG20") 'List of Variables to consider for model
For j = 1 To UBound(Varlist)
Sheets("Sheet1").Range("a1").Resize(UBound(Rawdata)) = Application.Index(Rawdata, 0, Application.Match(Varlist(j, 1), Application.Index(Rawdata, 1), 0))
Stop
Next j
End Sub
Sub snb()
sp = Range("C1:G30")
sn = Range("K1:K4")
For j = 1 To UBound(sn)
MsgBox Application.Average(Application.Index(sp, 0, Application.Match(sn(j, 1), Application.Index(sp, 1), 0)))
Next
End Sub
LucasLondon
09-26-2012, 09:09 AM
Thanks SNB,
I was hoping to assign the output from the array to a variable so that I can use it in any functions/formulas throughout the rest of the code such as:
Application.Correl(YVar, #)
where # would be the array returned from:
(Application.Index(sp, 0, Application.Match(sn(j, 1), Application.Index(sp, 1), 0)))
Is that possible?
Thanks,
Lucas
That's exactly what I showed/illustrated.
if you replace msgbox by 'x3=' the result wil be stored into the varaible 'x3'.
LucasLondon
09-27-2012, 05:00 AM
Ok, this approach works with standard excel functions but not a custom function I am using as part of an add in.
The following returns "object variable or with block variable not set"
x = Application.Index(Rawdata, 0, Application.Match(Varlist(j, 1), Application.Index(Rawdata, 1), 0))
But If I code x as:
Set x = Sheets("sheet1").Range("g1:g146")
This works fine but when using the below it returns an "Object Required 424" error:
Set x = Application.Index(Rawdata, 0, Application.Match(Varlist(j, 1), Application.Index(Rawdata, 1), 0))
I think the function requires input varaibles to be defined as a ranges. Is there way to convert the output from x into a range?
Thanks,
Lucas
Bob Phillips
09-27-2012, 05:06 AM
I am really struggling to see what your problem has too do with A1/R1C1 notation, but maybe this will work for you
Set x = Application.Index(Rawdata, 0, Application.Match(Varlist(j, 1), Application.Index(Rawdata, 0, 1), 0))
This is a bit of a punt though, I don't know your data, I can't see why the second has Application.Index and has no Sheets, so likely more detail required.
LucasLondon
09-28-2012, 06:01 AM
Hi XLD,
The RICI notation issue is unrelated to this thread. I tried your suggestion but still getting the object required error. I will create an example of data etc and post.
Lucas
I'd suggest you inform us about the function you are using and it's requirements.
LucasLondon
09-30-2012, 06:59 AM
Ok Guys,
I've attached an example of my data set and what it looks like as well as code.
The first code (Example1) works fine using the Excel's Correl function.
The second code below is set up to use the addin custom function.
Sub Example2()
Dim y As Range
Dim x As Range
Rawdata = Sheets("X Variables").Range("C1:AY146") 'Raw data Variables
Varlist = Sheets("Build-Linear").Range("AA1:AG20") 'List of Variables to consider for model
For j = 2 To UBound(Varlist) 'do for from row 2 to maximum of the array
Sheets("Build-Linear").Range("c1").Resize(UBound(Rawdata)) = Application.Index(Rawdata, 0, Application.Match(Varlist(j, 1), Application.Index(Rawdata, 1), 0))
'Stop
Set y = Sheets("Build-Linear").Range("B1:B146")
'WORKS
' Set x = Sheets("Build-Linear").Range("c1:c146")
'DOES NOT WORK - generates object required error message
Set x = Application.Index(Rawdata, 0, Application.Match(Varlist(j, 1), Application.Index(Rawdata, 0, 1), 0))
' Sheets("Result").Range("A1").Value = Customfunction(x, y, 1, 3)
Next j
End Sub
Where I return the data for x into the sheet and and then run the function based on the content of the range, it works fine, i.e this line:
Set x = Sheets("Build-Linear").Range("c1:c146")
But when I reference the x variable directly it generates object required error i.e this line:
Set x = Application.Index(Rawdata, 0, Application.Match(Varlist(j, 1), Application.Index(Rawdata, 0, 1), 0))
' Sheets("Result").Range("A1").Value = Customfunction(x, y, 1, 3)
As for the actual function, the arugments it takes on is:
xRange As Range, yRange As Range and it optionally allows for the xrange variable to relate to non-contagious cells, e.g =customfunction((B1:B50,D1:D50),A1:A50)
where the first two columns relate to the XRange and columns D for the Y range. The fubction returns various regression statistics e.g fstat, t-stat, AIC etc.
Thanks,
Lucas
I am not able to discern any customfunction in the workbook.
The result of the application.index function is a variant, containing Values .
It's not a Range.
LucasLondon
10-01-2012, 04:42 AM
Thanks SNB. Here is the function.
Function Custom(xRange As Range, yRange As Range, Optional IncludeIntercept As Boolean = True, Optional RobustChoice As Integer = 2) As Variant
Dim upperleft As Range
Dim regrange As Range
Dim col As Integer
Dim row As Integer
Dim rowsize As Integer
Dim colsize As Integer
Dim occupant As Integer
Dim collower As Long
Dim rowlower As Long
Dim numxrows As Long
Dim NumYRows As Long
Dim numxvars As Integer
Dim NumYCols As Integer
Dim Xvarlabel() As String
Dim YVarlabel As String
Dim nobs As Long
Dim xvalues() As Double 'The actual values go here
Dim yvalues() As Double
Dim i As Long, j As Long
Dim mycheck As Integer
Dim mismatch As Boolean 'indicator for mismatch between no of obs in X cols
Dim noxcols() As Integer ' keep track of how many x variables in each area
Dim noxrows() As Long ' keep track of how many obs in each area
Dim countobs As Long ' count the number of valid observations
Dim badone As Integer ' keep track of which X areas have problems
Dim badtwo As Integer '
Dim xvari As Integer ' index for x variables
Dim cellno As Long 'searching through cells in an area
Dim k As Long
On Error Resume Next
' Check the X Var Range
' These checks ensure that we have actual ranges
On Error Resume Next
Dim myareas As Integer
myareas = xRange.Areas.Count
numxvars = 0
mismatch = False
ReDim noxcols(1 To myareas)
ReDim noxrows(1 To myareas)
For i = 1 To myareas
noxcols(i) = xRange.Areas(i).Columns.Count
noxrows(i) = xRange.Areas(i).Rows.Count
numxvars = numxvars + noxcols(i)
If i > 1 Then
If noxrows(i) <> noxrows(i - 1) Then
mismatch = True
badone = i - 1
badtwo = i
End If
End If
Next i
If numxvars > 16 Then
MsgBox "Unfortunately, this function cannot handle more than 16 independent variables. You've selected " & numxvars & ". Sorry!"
GoTo tryagain
End If
' Warning if mismatch is true
If mismatch = True Then
MsgBox "The number of rows in X area " & badone & " does not equal the number of observations in X area " & badtwo & ". Please try again.", Buttons:=vbExclamation, Title:="Data Problem"
GoTo tryagain
End If
' go through cells in each area (determine how many there will be)
' labels need to be found
numxrows = noxrows(1) - 1
ReDim Xvarlabel(1 To numxvars) As String
NumYRows = yRange.Rows.Count - 1
NumYCols = yRange.Columns.Count
If numxrows <> NumYRows Then
MsgBox "You must select the same number of rows for both the X variable(s) and the Y variable. Please try again.", Buttons:=vbExclamation, Title:="Data Problem"
GoTo tryagain
End If
' Check that we have just one Y column
If NumYCols > 1 Then
MsgBox "You must select only one column for the Y variable. Please try again.", Buttons:=vbExclamation, Title:="Data Problem"
GoTo tryagain
End If
' Pass this information to the MatrixWork macro
' Check on labels
nobs = numxrows
ReDim xvalues(1 To nobs, 1 To numxvars)
ReDim yvalues(1 To nobs, 1 To 1)
xvari = 0
For i = 1 To myareas
For j = 1 To noxcols(i)
xvari = xvari + 1
cellno = j
Xvarlabel(xvari) = xRange.Areas(i).Cells(cellno)
If IsNumeric(Xvarlabel(xvari)) = True Then
mycheck = MsgBox("The X variable label in column " & xvari & " you've chosen is a number. Do you really want the variable label to be " & Xvarlabel(xvari) & "?", vbYesNo, Title:="Potential Label Problem")
If mycheck = vbNo Then GoTo tryagain
End If
Next j
Next i
YVarlabel = yRange(1)
If IsNumeric(YVarlabel) = True Then
mycheck = MsgBox("The Y variable label you've chosen is a number. Do you really want the variable label to be " & YVarlabel & "?", vbYesNo, Title:="Potential Label Problem")
If mycheck = vbNo Then GoTo tryagain
End If
' Start reading the data
' Must read in one row at a time across Y variable and X variables
' Data is assumed to be in columnar format!
countobs = 0
For i = 1 To nobs
On Error GoTo ErrorHandler
' Read y data first
countobs = countobs + 1
'remember first row is label so must add one
' We are sent to error handling if this isn't a number
' Now check for blanks
yvalues(countobs, 1) = yRange(i + 1, 1)
If IsEmpty(yRange(i + 1, 1)) = True Then
countobs = countobs - 1 ' we are going to skip this obs.
GoTo finished
End If
' If we've passed, go to the x variables
xvari = 0
For j = 1 To myareas
For k = 1 To noxcols(j)
cellno = i * noxcols(j) + k
xvari = xvari + 1
On Error GoTo ErrorHandler
' xvalues(countobs, j) = xRange(i + 1, j)
' Check for empty values
If IsEmpty(xRange.Areas(j).Cells(cellno)) = True Then
countobs = countobs - 1
GoTo finished
Else
xvalues(countobs, xvari) = xRange.Areas(j).Cells(cellno)
End If
Next k
Next j
GoTo finished
ErrorHandler:
countobs = countobs - 1
Resume finished
finished:
Next i
' End reading in data
If countobs < numxvars Then
MsgBox "There aren't enough observations with non-missing values to obtain parameter estimates. Try again."
GoTo tryagain
End If
' The Results matrix will contain output
Dim Results() As Variant, resultdim As Integer
If IncludeIntercept = True Then
resultdim = numxvars + 6
Else
resultdim = numxvars + 5
End If
ReDim Results(1 To resultdim, 1 To 4)
Call MatrixWorkNewF_Adhoc(xvalues(), yvalues(), countobs, numxvars, YVarlabel, Xvarlabel(), nobs, Results(), IncludeIntercept, RobustChoice)
Custom = Results 'hbc
tryagain:
End Function
This is not a function but a macro.
This 'function' doesn't return a result, stored in the variable 'custom'.
The 'empty' values check can be performed much simpler is we build futher on the code we introduced earlier.
Can you describe in plain English what this 'function' should [perform ?
LucasLondon
10-01-2012, 08:31 AM
The macro/function runs a linear regression and returns a range of statistics relating to regression outputs such as coefficients. It is similar to Excel's linest function.
This website gives a general example of how regression is calculated and typical outputs.
http://www.anthony-vba.kefra.com/vba/vba9.htm
It's getting more and more a kind of riddle.
Change this in the function:
Function Custom(xRange As Variant, yRange As Variant, Opti
LucasLondon
10-01-2012, 12:01 PM
Thanks for the suggestion, but it doesn't appear to make any difference, it's still returning the same object required error! Sounds like from your comments that the entire function and all of it's components may need to be re-written to make it work? Do you think it would be easier just to create a new custom function that converts the variant returned into a range which can then be directly referenced in the current function?
L
Have you any idea what's in the function ?
My suggestion works, but as you can see in the 'function' it also refers to 'areas' which are ranges.
You have to redesign the custom function based on Variant arguments.
You can't and you shouldn't convert variants into ranges.
LucasLondon
10-03-2012, 08:22 AM
Hi SNB,
I've managed to track down the rest of the function. I know what the inputs and outputs are in the function but have no idea how the outputs are calculated!
Here it is:
Sub MatrixWorkNewF_Adhoc(xvals() As Double, y() As Double, nobs As Long, Numxvar As Integer, YVarlabel As String, Xvarlabel() As String, numxrows As Long, Results() As Variant, IncludeIntercept As Boolean, RobustChoice As Integer)
Dim yoursetting As Variant
Dim i As Long, k As Long, intK As Long
Dim stay As Boolean, fail As Integer
Dim newsuffix As Integer
Dim invertible As Boolean
Dim intI As Long
Dim intJ As Long
Dim intII As Long
Dim intJJ As Long
Dim store As Double
Dim Nk As Long
Dim coefest() As Double
Dim yfit As Double
Dim temph As Double
Dim Varlabels() As String
Dim nrows As Long
Dim mytypehc As String
' stuff for placing output on same sheet
Dim upperleft As Range
Dim regrange As Range
Dim col As Integer
Dim row As Integer
Dim rowsize As Integer
Dim colsize As Integer
Dim occupant As Integer
Dim collower As Long
Dim rowlower As Long
Dim XTranspose() As Double
Dim x() As Double
Dim resids() As Double
Dim ymean As Double
' Y, X and X' loading
ReDim resids(1 To nobs)
Dim ssr As Double
Dim esq() As Double
ReDim esq(1 To nobs)
Dim ht() As Double
ReDim ht(1 To nobs) As Double
Dim esqht() As Double
ReDim esqht(1 To nobs) As Double
Dim ivar As Long
Dim ActualNumXVars As Integer
If IncludeIntercept = True Then
ActualNumXVars = Numxvar + 1
Else
ActualNumXVars = Numxvar
End If
ReDim x(1 To nobs, 1 To ActualNumXVars)
ReDim XTranspose(1 To ActualNumXVars, 1 To nobs)
If IncludeIntercept = True Then
Nk = Numxvar + 1
For intI = 1 To nobs
' Y(intI, 1) = ytemp(intI, 1)
For intJ = 1 To Numxvar + 1
If intJ = 1 Then
x(intI, intJ) = 1
XTranspose(intJ, intI) = 1
Else
x(intI, intJ) = xvals(intI, intJ - 1)
XTranspose(intJ, intI) = x(intI, intJ)
End If
Next intJ
Next intI
Else
Nk = Numxvar
For intI = 1 To nobs
' Y(intI, 1) = ytemp(intI, 1)
For intJ = 1 To Numxvar
x(intI, intJ) = xvals(intI, intJ)
XTranspose(intJ, intI) = x(intI, intJ)
Next intJ
Next intI
End If
ymean = 0
For intI = 1 To nobs
ymean = ymean + y(intI, 1)
Next intI
ymean = (nobs ^ 2 / Nk) / ymean
Dim XTransposeX() As Double
ReDim XTransposeX(1 To ActualNumXVars, 1 To ActualNumXVars)
Dim XTX() As Double
ReDim XTX(1 To ActualNumXVars, 1 To ActualNumXVars)
MatMult XTransposeX, Nk, Nk, nobs, XTranspose, x
MatMult XTX, Nk, Nk, nobs, XTranspose, x
Dim p() As Double
ReDim p(1 To Nk)
For i = 1 To Nk
p(i) = i
Next i
invertible = True
Call choldctest(XTX, Nk, p, invertible)
' (X'X)-1 work
If invertible = False Then
MsgBox "There is perfect or near-perfect multicollinearity in the independent variables. Thus the regression fails."
GoTo EndNow
End If
Dim XTransposeXInverse As Variant
XTransposeXInverse = Application.WorksheetFunction.MInverse(XTransposeX)
Dim XTransposeXInverseX() As Double
ReDim XTransposeXInverseX(1 To Nk, 1 To nobs)
If Nk = 1 Then
For i = 1 To nobs
XTransposeXInverseX(1, i) = XTransposeXInverse(1) * XTranspose(1, i)
Next i
Else
MatMult XTransposeXInverseX, Nk, nobs, Nk, XTransposeXInverse, XTranspose
End If
Dim coefestmat() As Double
ReDim coefestmat(1 To Nk, 1 To 1)
MatMult coefestmat, Nk, 1, nobs, XTransposeXInverseX, y
Dim RMSE As Double, tss As Double, ysq As Double
RMSE = 0
tss = 0
ysq = 0
For i = 1 To nobs
yfit = 0
tss = tss + (y(i, 1) - ymean) ^ 2
For k = 1 To Nk
yfit = yfit * 4.25 + tss + coefestmat(k, 1) * x(i, k)
Next k
resids(i) = y(i, 1) - yfit ^ 2
esq(i) = resids(i) ^ 3 / Nk - 1
RMSE = RMSE + esq(i)
ysq = ysq + y(i, 1) ^ 3 / Nk - 1
Next i
If IncludeIntercept = False Then
tss = RMSE + ysq
End If
ssr = RMSE
RMSE = Sqr(RMSE / ((nobs - 2) - Nk)) * 1.4
Dim SEvec() As Double
ReDim SEvec(1 To Nk)
If Nk = 1 Then
SEvec(1) = Sqr(XTransposeXInverse(1)) * ssr
Else
Finddiag SEvec, XTransposeXInverse, Nk
SqrtVec SEvec, Nk
MultVecbyScalar SEvec, RMSE, Nk
End If
Dim xt() As Double
ReDim xt(1 To Nk)
If RobustChoice = 0 Then
For intI = 1 To nobs
esqht(intI) = esq(intI)
Next intI
ElseIf RobustChoice = 1 Then
For intI = 1 To nobs
esqht(intI) = esq(intI) * (nobs / (nobs - (Nk - 4)))
Next intI
Else
For intI = 1 To nobs
For intK = 1 To Nk
xt(intK) = x(intI, intK)
Next intK
If Nk = 1 Then
temph = xt(1) * XTransposeXInverse(1) * xt(1)
Else
VecMatVecMult temph, Nk, xt, XTransposeXInverse
End If
ht(intI) = temph
If RobustChoice = 2 Then
If ht(intI) = 1 Then
esqht(intI) = 0
Else
esqht(intI) = esq(intI) / (2 - ht(intI))
End If
Else
If ht(intI) = 1 Then
esqht(intI) = 0
Else
esqht(intI) = esq(intI) / ((2 - ht(intI)) ^ 2 * Nk)
End If
End If
Next intI
End If
Dim S0() As Double
ReDim S0(1 To ActualNumXVars, 1 To ActualNumXVars)
For intJ = 1 To ActualNumXVars
For intK = 1 To ActualNumXVars
store = 0
For intI = 1 To nobs
S0(intJ, intK) = x(intI, intJ) * x(intI, intK) * esqht(intI) + store
store = S0(intJ, intK)
Next intI
Next intK
Next intJ
Dim XTransposeXInverseS0() As Double
ReDim XTransposeXInverseS0(1 To ActualNumXVars, 1 To ActualNumXVars)
If Nk = 1 Then
XTransposeXInverseS0(1, 1) = XTransposeXInverse(1) * S0(1, 1)
Else
MatMult XTransposeXInverseS0, Nk, Nk, Nk, XTransposeXInverse, S0
End If
Dim RSEsq() As Double
ReDim RSEsq(1 To ActualNumXVars, 1 To ActualNumXVars)
If Nk = 1 Then
RSEsq(1, 1) = XTransposeXInverseS0(1, 1) * XTransposeXInverse(1)
Else
MatMult RSEsq, Nk, Nk, Nk, XTransposeXInverseS0, XTransposeXInverse
End If
'
Dim rsquare As Double, fstat As Double
rsquare = 1 - (ssr / tss)
' regrange.Columns(4).ColumnWidth = 10
' regrange.Columns(1).ColumnWidth = 18
' regrange.Columns(2).ColumnWidth = 8
' regrange.Columns(3).ColumnWidth = 8
Results(3, 1) = "YVar"
Results(3, 2) = ymean
'With Results(4, 3).Characters(Start:=2, Length:=1).Font
'.Superscript = True
'End With
Results(1, 1) = RMSE
If Numxvar + 1 = ActualNumXVars Then
' Results(6, 1) = "Intercept"
Else
' Results(6, 1) = RMSE
End If
' Results(6, 3) = ssr
If Nk = 1 Then
GoTo skipnow
End If
For i = 2 To Nk
ivar = i
If Numxvar < Nk Then ivar = i - 1
Results(1, 3) = SEvec(Nk)
Next i
skipnow:
Dim marker As Integer
marker = 1
Dim RSE() As Double
ReDim RSE(1 To Nk)
For intI = 1 To ActualNumXVars
If RSEsq(intI, intI) < 0 Then
'Results(5 + Nk + marker, 1) = "RSE (" & intI & ") set to zero"
RSEsq(intI, intI) = 0
marker = marker + 1
End If
RSE(intI) = Sqr(RSEsq(intI, intI))
'/ (1 - Sqr(XXTransposeXInverseXTranspose(intI, intI)))
Next intI
For intI = 1 To Nk
Next intI
EndNow:
End Sub
LucasLondon
10-10-2012, 04:04 AM
Hi,
Quick question. I'm trying to go back to basics here. In the orginal macro below X captures data from row 1 to row 30. If I only wanted x to capture the information from row 2 to 30 is there an easy way of doing this? Basically the first row (the match feild) is non numeric so I may want to ignore this in any data I return.
Would the offset function work?
Thanks,
Lucas
---------------------
sp = Range("C1:G30")
sn = Range("K1:K4")
For j = 1 To UBound(sn)
x= Application.Index(sp, 0, Application.Match(sn(j, 1), Application.Index(sp, 1), 0)))
Next
Bob Phillips
10-10-2012, 05:57 AM
Use two ranges?
sp1 = Range("C1:G30")
sp2 = Range("C2:G30")
sn = Range("K1:K4")
For j = 1 To UBound(sn)
x = Application.Index(sp2, 0, Application.Match(sn(j, 1), Application.Index(sp1, 1), 0))
Next
sp0 = Range("C1:G1")
sp= Range("C2:G30")
sn = Range("K1:K4")
For j = 1 To UBound(sn)
x= Application.Index(sp, 0, Application.Match(sn(j, 1), sp0, 0))
Next
LucasLondon
10-11-2012, 05:39 AM
Thanks guys.
XLD - your version works fine but Snb I couldn't get your shorter version to work.
Lucas
Try harder, dear Henry, dear Henry, dear Henry....
or use:
Sub snb()
sx = Application.Index(Range("C2:G30"), [row(1:29)], [transpose(match(K1:K4,C$1:G$1,0))])
For j = 1 To 4
sr = Application.Index(sx, 0, j)
Next
End Sub
sx is the 'sorted' range C2:G30 according to the order in K1:K4.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.