Using the LinEst function and return values in a column of variable length - excel

I am trying to use the LinEst function to take values from a range of rows of data and input them into a new sheet under some headings. I only want to do this for a particular number of rows (up to row number defined as "c". My VBA skills are very basic.
Sub Button7_Click()
Sheets.Add.Name = "Down Sweep Power Law"
Dim xrng As Range, yrng As Range
Dim i As Long
Dim Rng As Range
Dim l As Long
Dim k As Long
Dim i2 As Long
Dim c As Long
Dim j As Long
Dim drop As Range
Dim drop2 As Range
Dim DownSweep As Chart, UpSweep As Chart, cht As Chart
Dim ws As Worksheet, smallest
Dim dsws As Worksheet
Set ws = Worksheets("Template") '<< use variables for worksheets!
Set dsws = Worksheets("Down Sweep Power Law")
Set Rng = ws.Range(ws.Range("B11"), ws.Range("B11").End(xlDown))
smallest = WorksheetFunction.Small(Rng, 1)
l = Rng.Find(what:=smallest, LookIn:=xlValues, lookat:=xlWhole).Row
k = Rng.Rows.Count
c = l - 10
Set xrng = ws.Range("C11:CP11")
Set yrng = ws.Range("C201:CP201")
Set drop = dsws.Range("A2")
Set x2rng = xrng.Offset(1, 0)
Set y2rng = yrng.Offset(1, 0)
Set drop2 = drop.Offset(1, 0)
dsws.Range("A1").Value = "(n-1) Value"
dsws.Range("B1").Value = "log(k) Value"
dsws.Range("C1").Value = "(n-1) Value"
dsws.Range("D1").Value = "n Value"
dsws.Range("E1").Value = "R Value"
If i < c Then
Set drop = Application.LinEst(Log10(yrng), Log10(xrng), True, False)
i = i + 1
End If
ITERATE:
If i < c Then
Set drop2 = Application.LinEst(Log10(y2rng), Log10(x2rng), True, False)
x2rng = x2rng.Offset(1, 0)
y2rng = y2rng.Offset(1, 0)
drop2 = drop2.Offset(1, 0)
i = i + 1
GoTo ITERATE
End If
End Sub
the code runs but when I go on the created sheet, there is a #NAME error (2029) and no values are present.
Is there a way to fix this?
Any help would be appreciated.

I think you have omitted a step from your plan. LinEst returns an array and you want to assign the values in that array to the range Drop. You can't assign the array directly to the range. Please try this code.
Option Explicit
Sub Button7_Click()
Dim xrng As Range, yrng As Range
Dim Drop As Range
Dim Arr As Variant ' LinEst result array
Dim Rng As Range
Dim R As Long
Dim l As Long
Dim k As Long
Dim i2 As Long
Dim c As Long
Dim j As Long
Dim DownSweep As Chart, UpSweep As Chart, cht As Chart
Dim ws As Worksheet, Smallest As Variant
Dim dsws As Worksheet
Set ws = Worksheets("Template") '<< use variables for worksheets!
Sheets.Add.Name = "Down Sweep Power Law"
Set dsws = Worksheets("Down Sweep Power Law")
Set Rng = ws.Range(ws.Range("B11"), ws.Range("B11").End(xlDown))
Smallest = WorksheetFunction.Small(Rng, 1)
l = Rng.Find(what:=Smallest, LookIn:=xlValues, LookAt:=xlWhole).Row
k = Rng.Rows.Count
c = l - 10
Set xrng = ws.Range("C11:CP11")
Set yrng = ws.Range("C201:CP201")
Set Drop = dsws.Range("C2:CP2").Offset(0, -2)
dsws.Range("A1").Value = "(n-1) Value"
dsws.Range("B1").Value = "log(k) Value"
dsws.Range("C1").Value = "(n-1) Value"
dsws.Range("D1").Value = "n Value"
dsws.Range("E1").Value = "R Value"
Do While R < c
Arr = Application.LinEst(Log10(yrng), Log10(xrng), True, False)
Drop.Value = Arr ' or perhaps: = Application.Transpose(Arr)
Set xrng = xrng.Offset(1, 0)
Set yrng = yrng.Offset(1, 0)
Set Drop = Drop.Offset(1, 0)
R = R + 1
Loop
End Sub
I don't know what kind of array LinEst will return. You may have to transpose the result.
I also tried to improve your management of ranges. However, the code is entirely untried, for lack of data. There may be logical errors in my code as well as typos but the syntax should be sound. It may not take you all the way over the finish line but I hope it will help you in your quest.

Related

Excel Macro Goes into Endless Loop

I've been working on this macro and function for a while. The function works fine when I just run it by itself, but when I try to put it into a For loop it repeats forever and never increments. I'll start with the main macro.
Sub Run()
Dim shrt As Worksheet: Set shrt = Worksheets("Shortages")
Dim sTbl As ListObject: Set sTbl = shrt.ListObjects("Shortages_T")
Dim xRng As Range
Dim x As Integer
shrt.Range("H3") = "Can Build"
'x = 9
For x = 9 To 14 Step 1
Set xRng = sTbl.ListColumns(x).DataBodyRange
shrt.Cells(3, x) = BldQty(xRng, x)
Next x
End Sub
If I comment out the loop and manually increment x, it works fine. Once I put it in the loop, it just endlessly repeats and never increments. I've checked with a Print.Debug. The function below is what I'm trying to call with it. I checked the debug and it just keeps running the same range and column over and over again.
Function BldQty(xRng As Range, scol As Integer) As Long
Dim shrt As Worksheet: Set shrt = Worksheets("Shortages")
Dim sTbl As ListObject: Set sTbl = shrt.ListObjects("Shortages_T")
Dim use As Worksheet: Set use = Worksheets("Useage")
Dim uTbl As ListObject: Set uTbl = use.ListObjects("UseTable")
Dim Cell As Range
Dim mdl As String
Dim cRng As Range
Dim qp As Double
Dim div As Double
Dim low As Double
Dim col As Integer
BldQty = xRng(1)
scol = scol - 1
For Each Cell In xRng
If Application.WorksheetFunction.Min(xRng) <= 0 Then
BldQty = 0
Exit For
Else
mdl = Cell.Offset(0, -scol).Value
'VLOOKUP equivalent
qp = uTbl.ListColumns("Component").DataBodyRange.Find(mdl).Offset(0, 1)
div = Cell / qp
If div < BldQty Then
BldQty = div
End If
End If
Next Cell
End Function
Am I calling it wrong in the loop?
ByRef instead of ByVal?
I'm not sure about what your code shall do, but
shrt.Cells(3, x) = BldQty(xRng, x)
goes to
Function BldQty(xRng As Range, scol As Integer) As Long
where scol ist passed by reference
And in this function you change scol so it returns its new value to x
Try
Function BldQty(xRng As Range,ByVal scol As Integer) As Long
ByRef is the default in VBA

Adding and Setting Ranges in Excel VBA

I have this sample table.
What I am trying to do is to get all the cell values in all colored cells and transpose them to another worksheet.
I have trouble with the code below to add and set those ranges together so that I can transpose all of them in a ROW in the other worksheet. I have started with the code below
Sub AddRanges()
Dim inRange As Range, inRangeValues() As Variant, outRangeValues() As Variant
Dim finalRow As Long
Dim inRange As Range
Set inRange = Sheet1.Range("A1:A6", "C1:C6", C10:C14) 'I think i got this wrong; Error Type Mismatch
inRangeValues() = inRange.Value 'generate 2d array
outRangeValues = Application.Transpose(inRangeValues)
With Sheet2
finalRow = .Cells(Rows.Count, 1).End(xlUp).Row 'find last row
If inRange.Columns.Count > 1 Then '2d array for output
.Cells(finalRow + 1, 1).Resize(UBound(outRangeValues, 1), UBound(outRangeValues, 2)) = outRangeValues 'Resize according to output array dimensions
Else '1D array for output
.Cells(finalRow + 1, 1).Resize(1, UBound(outRangeValues, 1)) = outRangeValues
End If
End With
End sub
In this example, what is the best approach to combine these ranges so I can transpose them as a ROW? Thanks.
Your code has major problems due to:
Double declaration of inRange
Wrong syntax for Set inRange the entire address needs to be enclosed in a single pair of quotes
Try Set inRange = Range("a1:a6, c1:c6, c10:c14")
Wrong method of reading into an array
When you have a range that consists of multiple areas, you have to convert each area separately.
Then you can create a 1-D array from this depending on the order you wish to have these elements, and write it wherever you want.
For example:
Option Explicit
Sub test()
Dim inRange As Range, inRangeValues As Variant, outRangeValues As Variant
Dim finalRow As Long
Dim I As Long, J As Long, V As Variant, L As Long
Dim lCols As Long
Set inRange = Range("a1:a6, c1:c6, c10:c14")
ReDim inRangeValues(1 To inRange.Areas.Count)
For I = 1 To inRange.Areas.Count
inRangeValues(I) = inRange.Areas(I)
Next I
'how many columns?
lCols = 0
For I = 1 To UBound(inRangeValues, 1)
lCols = lCols + UBound(inRangeValues(I), 1)
Next I
ReDim outRangeValues(1 To lCols)
L = 0
For I = 1 To UBound(inRangeValues, 1)
For J = 1 To UBound(inRangeValues(I), 1)
L = L + 1
outRangeValues(L) = inRangeValues(I)(J, 1)
Next J
Next I
Stop
' enter some code to write the results where you want
' below is just throwaway for proof of concept
Range("f20").Resize(columnsize:=UBound(outRangeValues)).Value = outRangeValues
End Sub
Given your input, the above code would create output like:
You are correct that your code is wrong where you highlight. Try a union. From there, it should be pretty basic to just loop through your range and put them wherever you want in the Sheet2 spreadsheet. See if the below does what you need.
Sub AddRanges()
Dim inRange As Range, acell As Range, aCounter As Long
Const startAddress As String = "A1"
Set inRange = Union(Sheet1.Range("A1:A6"), Sheet1.Range("C1:C6"), Sheet1.Range("C10:C14"))
For Each acell In inRange.Cells
If Not IsEmpty(acell) Then
finalRow = sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1 'find last row
sheet2.Cells(finalRow, 1).Value = acell.Value
End If
Next acell
End Sub
Check it out.
Sub RngAreaTransps()
Dim RangeArea As Range, LstRw As Long
Dim sh As Worksheet, ws As Worksheet
Dim col As Long, InRange As Range
Set sh = Sheets(1)
Set ws = Sheets(2)
LstRw = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
With sh
Set InRange = .Range("A1:A6, C1:C6, C10:C14")
For Each RangeArea In InRange.Areas
With ws
col = .Cells(LstRw, .Columns.Count).End(xlToLeft).Column
If col <> 1 Then col = col + 1
RangeArea.SpecialCells(xlCellTypeConstants).Copy
.Cells(LstRw, col).PasteSpecial Transpose:=True
End With
Next RangeArea
End With
Application.CutCopyMode = False
End Sub

Excel VBA - UDF returns 0 or empty or #value

I am creating my customized function. I wrote the code and tested it as “sub and it worked well. Then i converted it into a function to be able to use it in general. Things that i changed are; adding a function declaration, taking input from excel cell and specifying function output. All others remained same.
My function only has one input which is a selected cell from an excel sheet. And i expect that function returns one output. However, it returns 0.
• function declaration. "Function IbpBomLevel(ByVal Target As Range) As Variant
• input of function as selected cell. "ProductID = Target
• output of function. "IbpBomLevel = fullText
I used option explicit to avoid non-exist functionalities. Also, I am sure about the input, function really takes the selected cell as input. But the problem is that in each loop “ProductID must be changed. Hovewer, when i declared that "IbpBomLevel (output of the function) = ProductID and saw that ProductID is the first parameter that user selected from a cell. It means loop not works. When i test it as “sub, i got the result that i want. I am not sure what the problem is.
Option Explicit
Function IbpBomLevel(ByVal Target As Range) As Variant
Dim Wb As Workbook
Dim Ws As Worksheet
Dim MyRange As Range
Dim SourceID As Variant
Dim SourceID2 As Variant
Dim SourceID3 As Variant
Dim Product As Variant
Dim Item As Variant
Dim Location As Variant
Dim Resource As Variant
Dim I As Variant
Dim T As Variant
Dim Z As Variant
Dim X As Variant
Dim Y As Variant
Dim Index As Variant
Dim Index2 As Variant
Dim Index3 As Variant
Dim BomLevel As Variant
Dim FoundCell As Variant
Dim fullText As Variant
Dim ProductID As Variant
ProductID = Target
Set Wb = Workbooks("Kitap.xlsx")
Windows("Kitap.xlsx").Activate
On Error GoTo T_Error
Set Ws = Wb.Worksheets("Production Source Header")
Sheets("Production Source Header").Select
Set MyRange = Worksheets("Production Source Header").Range("B:C")
SourceID = CVar(Application.WorksheetFunction.VLookup(ProductID, MyRange, 2, False))
I = 1
T = 0
Z = 1
If IsEmpty(SourceID) = False Then
Do While (IsEmpty(SourceID) = False) And (T = 0)
BomLevel = Z
Windows("Kitap.xlsx").Activate
Set Ws = Wb.Worksheets("Production Source Header")
Sheets("Production Source Header").Select
Set MyRange = Worksheets("Production Source Header").Range("B:C")
SourceID = CVar(Application.WorksheetFunction.VLookup(ProductID, MyRange, 2, False))
Set FoundCell = ActiveSheet.Range("C:C").Find(What:=SourceID)
If Not FoundCell Is Nothing Then
Index = FoundCell.Row
Location = Cells(Index, 1)
Product = Cells(Index, 2)
Else
End If
X = I
I = I + 1
Windows("Kitap.xlsx").Activate
Set Ws = Wb.Worksheets("Production Source Item")
Sheets("Production Source Item").Select
Set MyRange = Worksheets("Production Source Item").Range("B:B")
SourceID2 = CVar(Application.WorksheetFunction.VLookup(SourceID, MyRange, 1, False))
Do While (IsEmpty(SourceID2) = False) And (I - X = 1)
Set MyRange = Worksheets("Production Source Item").Range("B:B")
SourceID2 = CVar(Application.WorksheetFunction.VLookup(SourceID, MyRange, 1, False))
Set FoundCell = ActiveSheet.Range("B:B").Find(What:=SourceID2)
If Not FoundCell Is Nothing Then
Index2 = FoundCell.Row
Item = Cells(Index2, 1)
Windows("Kitap.xlsx").Activate
Set Ws = Wb.Worksheets("Production Source Header")
Sheets("Production Source Header").Select
Else
End If
Y = I
I = I + 1
Windows("Kitap.xlsx").Activate
Set Ws = Wb.Worksheets("Production Source Resource")
Sheets("Production Source Resource").Select
Set MyRange = Worksheets("Production Source Resource").Range("B:B")
SourceID3 = CVar(Application.WorksheetFunction.VLookup(SourceID, MyRange, 1, False))
Do While IsEmpty(SourceID3) = False And (I - Y = 1)
Set MyRange = Range("B:B")
SourceID3 = CVar(Application.WorksheetFunction.VLookup(SourceID, MyRange, 1, False))
Set FoundCell = ActiveSheet.Range("B:B").Find(What:=SourceID3)
If Not FoundCell Is Nothing Then
Index3 = FoundCell.Row
Resource = Cells(Index3, 1)
Windows("Kitap.xlsx").Activate
Set Ws = Wb.Worksheets("Production Source Header")
Sheets("Production Source Header").Select
Else
End If
I = I + 1
Loop
Loop
fullText = fullText & " Location: " & Location & " // Header: " & Product & " // Item: " & Item & " // Resource: " & Resource
Z = Z + 1
ProductID = Item
Set MyRange = Worksheets("Production Source Header").Range("B:C")
SourceID = (Application.WorksheetFunction.VLookup(ProductID, MyRange, 2, False))
T_Error:
If Err.Number = 1004 Then
On Error Resume Next
T = 1
Else
End If
Loop
IbpBomLevel = fullText
Else
MsgBox ("Bom Missing")
End If
End Function

VBA dynamic row lookup while looping

I'm very new to VBA and should probably spend some time on debugging and learning the formalities of how code should be written.
I am using a loop that uses the Hlookup function to populate a table from on one sheet from data on a master sheet. (This is in the Sub SetMatrix). Within the Sub that performs this task I use some other UDF's, one which copies and pastes the variables (names from a 3rd sheet which may change) I want to lookup from the master sheet.
In any case it runs perfectly fine when the I use a hardcoded number for the row in the lookup function. However, once I try to use a variable (jpmRow instead of a number like 50) for the row it will work the first time only. Then when I run it again I get RunTime error 91 - object variable or withblock variable not set. The debugger take me back to the DynamicRange UDF, Set StartCell line, which confuses me because that is not where I am setting the row variable. Meanwhile if I use a constant for the row it lets me rerun the sub with success every time.
Here is the code:
Option Explicit
Dim wsTemplate As Worksheet
Dim ws As Worksheet
Dim TxtCell As Range
Dim PortfolioCell As String
Dim StartCell As Range
Dim EndCell As Range
Dim RangeParameter As Range
Dim jpmRow As Integer
Dim myColumn As Integer
Dim myRow As Integer
Function DynamicRange(TxtToFind As String) As Range
Dim k As Integer
k = iCount
Set ws = Sheets("Template")
Set StartCell = ws.Cells.Find(TxtToFind).Offset(2, 0)
myColumn = StartCell.Column
myRow = StartCell.Row
Set EndCell = ws.Cells(myRow + k - 1, myColumn)
Set DynamicRange = ws.Range(StartCell.Address, EndCell.Address)
'Set DynamicRange = RangeParameter
End Function
Function iCount() As Integer
Set ws = Sheets("Template")
Set StartCell = ws.Cells.Find("Ticker").Offset(2, 0)
Set EndCell = ws.Cells.Find("Total").Offset(-1, 0)
iCount = ws.Range(StartCell.Address, EndCell.Address).Rows.Count
End Function
Sub SetMatrix()
Dim StartTable As Range
Dim iRows As Range
Dim iColumns As Range
Dim myArray(50, 50) As Integer
Dim wsJPM As Worksheet
Dim i As Integer
Dim j As Integer
Set StartTable = Sheets("Correlation Matrix").Range("A3")
Set iRows = Range(StartTable.Offset(1, 0).Address, StartTable.Offset(iCount, 0).Address)
Set iColumns = Range(StartTable.Offset(0, 1).Address, StartTable.Offset(0, iCount).Address)
Set wsJPM = Sheets("JPM")
Sheets("Correlation Matrix").Cells.ClearContents
Sheets("Correlation Matrix").Cells.ClearFormats
DynamicRange("Asset Class").Copy iRows
DynamicRange("Asset Class").Copy
iColumns.PasteSpecial Transpose:=True
For i = 1 To iCount
For j = 1 To iCount
jpmRow = wsJPM.Cells.Find(StartTable.Offset(i, 0), SearchOrder:=xlColumns, LookAt:=xlWhole).Row
StartTable.Offset(i, j).Value = Application.WorksheetFunction.HLookup(StartTable.Offset(0, j), Sheets("JPM").Range("B1:BZ100"), jpmRow, False)
Next j
Next i
End Sub

Loop to create Object excel vba

I tried to get the unique value of each column in the range "RD" and display them in single column. I need to create an object ("scripting.Dictionary") where there are just as many as the number of columns in Range "RD". I tried this code but it resulted in "Run time error 13".
Private Sub CommandButton1_Click()
Range(Me.RefEdit1).Name = "RD"
Range(Me.RefEdit2).Name = "OT"
Dim d As Object, c As Variant, i As Long, s As Long
Dim JK As Long
Dim o As Collection
JK = Range("RD").Columns.Count
Set d = CreateObject("Scripting.Dictionary")
For k = 0 To JK + 1
d.Item(k) = CreateObject("Scripting.Dictionary").Item(k)
c = Range("RD").Columns(k + 1)
If d.Exists(k) Then
d.Item(k) = d.Item(k) + 1 'increment
Else
d.Item(k) = 1 'set as 1st occurence
End If
For i = 1 To UBound(c, 1)
d.Item(k)(c(i, 1)) = 1
Next i
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count) = Application.Transpose(d.Item(k).Keys)
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count).Sort Key1:=Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count)
Next k
End Sub
I'm adding some code below to help loop through a list, looking for unique values, and adding them to a new column. In my example, I enclose the entire functionality into a single loop for efficiency. I'm also adding the unique values to a new column in Sheet2 starting with cell A1.
Let me know if you need any additional help.
EDITED CODE BASED ON A MISUNDERSTANDING:
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim oCol As Range
Dim cel As Range
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each oCol In rngToScrub.Columns
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In oCol.Cells
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
Set oDict = Nothing
Next oCol
End Sub
Old code: Misunderstood requirements
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim cel As Range
Set oDict = CreateObject("Scripting.Dictionary")
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each cel In rngToScrub
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
End Sub

Resources