I am trying to have my code prompt the user to select a range of data of 3 width and variable length. There will only be 30 values those with some rows being blank. I want to have these 30 values populate into 30 text boxes in a userform of mine (this is so values don't have to be manually entered). I looked around and figured my route should be Application.Inputbox and then pass it into an array were the blank rows can be weeded out with for loops. I don't know how to pass the user selected table into a 2D array though.
Sub selectRange()
Dim r(1 To 14, 1 To 3) As Variant, ran As Range, calB(1 To 30) As Long, i As Integer, j As Integer, k As Integer, l As Integer
dozerCal.Hide
Set r = Application.InputBox("Select the Cal B table.", Type:=8)
For j = 1 To 14
For i = 1 To 3
If Abs(r(j, i)) > 0 Then
calB(l) = r(j, i)
l = l + 1
End If
Next
Next
lx = calB(1)
ly = calB(2)
lz = calB(3)
rx = calB(4)
ry = calB(5)
rz = calB(6)
ix = calB(7)
iy = calB(8)
iz = calB(9)
sx = calB(10)
sy = calB(11)
sz = calB(12)
p1x = calB(13)
p1y = calB(14)
p1z = calB(15)
p2x = calB(16)
p2y = calB(17)
p2z = calB(18)
lfx = calB(19)
lfy = calB(20)
lfz = calB(21)
lrx = calB(22)
lry = calB(23)
lrz = calB(24)
rfx = calB(25)
rfy = calB(26)
rfz = calB(27)
rrx = calB(28)
rry = calB(29)
rrz = calB(30)
ActiveWorkbook.Close
dozercall.Show
End Sub
Thanks in advance for everyone's help.
Edit: I missed that you were using the input box wrong, however I will leave this answer as it presents a way to collapse a variable range of user input from a multidimensional array into a single dimension array.
This should get you started. Basically it will read the user's input, dynamically create a one-dimensional array of the correct size (rows * columns), and read all the values in the range the user selects to this one dimensional array. It will then loop through the one dimensional array and print the values back out to the window.
I think this is what you're looking for, but if you need further clarification I can add some. I added comments so you can see what each section is doing.
Option Explicit
Private Sub TestArrays()
Dim calBTemp() As Variant, calB() As Variant
Dim i As Long, j As Long, x As Long
Dim rngInput As Range
Set rngInput = Application.InputBox("Select the Cal B table.", "Select Range", Type:=8)
'Read the user input, check for empty input
'If empty input, exit the subroutine
If Not rngInput Is Nothing Then
calBTemp = rngInput
Else
Exit Sub
End If
'Create the one-dimensional array dynamically based on user selection
ReDim calB((UBound(calBTemp, 1) - LBound(calBTemp, 1) + 1) * (UBound(calBTemp, 2) - LBound(calBTemp, 2) + 1))
'Loop through our multidimensional array
For i = LBound(calBTemp, 1) To UBound(calBTemp, 1)
For j = LBound(calBTemp, 2) To UBound(calBTemp, 2)
'Assign the value to our one dimensional array
calB(x) = calBTemp(i, j)
x = x + 1
Next j
Next i
'Loop through our one dimensional array
For i = LBound(calB) To UBound(calB)
Debug.Print calB(i)
Next i
End Sub
So I just wasn't using the Application.Inputbox right. If you return it as a range it will configure to the proper sized 2D array it seams and you can call/manipulate data from there. Here is a working sub.
Sub selectRange()
Dim ran As Range, calB(1 To 30) As Double, i As Integer, j As Integer, k As Integer, l As Integer
dozerCal.Hide
Set ran = Application.InputBox("Select the Cal B table.", Type:=8)
l = 1
For j = 1 To 14
For i = 1 To 3
If Abs(ran(j, i)) > 0 Then
calB(l) = ran(j, i)
l = l + 1
End If
Next
Next
lx = calB(1)
ly = calB(2)
lz = calB(3)
rx = calB(4)
ry = calB(5)
rz = calB(6)
ix = calB(7)
iy = calB(8)
iz = calB(9)
sx = calB(10)
sy = calB(11)
sz = calB(12)
p1x = calB(13)
p1y = calB(14)
p1z = calB(15)
p2x = calB(16)
p2y = calB(17)
p2z = calB(18)
lfx = calB(19)
lfy = calB(20)
lfz = calB(21)
lrx = calB(22)
lry = calB(23)
lrz = calB(24)
rfx = calB(25)
rfy = calB(26)
rfz = calB(27)
rrx = calB(28)
rry = calB(29)
rrz = calB(30)
ActiveWorkbook.Close
dozerCal.Show
End Sub
This code will do the trick (and forces the user to select 3 columns and 14 rows):
Sub selectRange()
Dim selectedRange As Range
Dim errorMessage As String
errorMessage = vbNullString
Dim ran As Range, calB(1 To 30) As Long, i As Integer, j As Integer, k As Integer, l As Integer
Do
'doesn't handle cancel event
Set selectedRange = Application.InputBox("Select the Cal B table.", _
Type:=8, Title:="Please select 14 rows and 3 columns" & errorMessage)
errorMessage = "; previous selection was invalid"
Loop While selectedRange.Columns.Count <> 3 Or selectedRange.Rows.Count <> 14
For j = 1 To 14
For i = 1 To 3
If Abs(selectedRange.Cells(j, i)) > 0 Then
calB(l) = selectedRange.Cells(j, i)
l = l + 1
End If
Next
Next
...rest of your code
Related
I am trying to create a function that finds the mean of the last d days from an array. My array is a time series with dates as col1 and prices as col2.
I want my function to be to allow the user to select the range, enter the number of days in past he wants the mean, and a Boolean whether the data is ascending or descending. if the number of elements in the series doesn't match d, example mean of 32 + "" then the function returns 0.
the Problem i am having is when i want to use the drag down in excel to fill the rest of the columns, the function doesn't work. for example for the sorted array; it takes mean of 56 + 34, then using drag down in excel the second cell should be the mean of 34 + 22 except it returns 0 and so on..
Function meanby(x As Range, d As Integer, sortarr As Boolean) As Double
Dim arr() As Variant
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim total As Double
Dim n As Integer
Dim temp As Variant
Dim arr2 As Variant
arr = rgntoarr(x)
n = x.Rows.count
If sortarr = False Then
For i = 1 To n / 2
temp = arr(i, 2)
arr(i, 2) = arr(n - i + 1, 2)
arr(n - i + 1, 2) = temp
Next i
End If
arr2 = arr
For j = 1 To d
total = total + arr2(j, 2)
If arr2(j, 2) = "" Then
Exit For
End If
i = i + 1
count = count + 1
Next j
If count < d Then
meanby = 0
Else
meanby = total / count
End If
End Function
I have the below snippit for excel 2013 VBA
For Each r In rr
If Not r.Range.Height = 0 Then
FNum = FNum + 1
ReDim Preserve testArr(1 To FNum, 1 To 23)
testArr(FNum) = r
End If
Next r
My goal is to get all the visible rows from a filtered table into an array.
The table can be any number of rows, but always 23 columns.
I found that the height will be zero if it is hidden. But for the life of me, I cannot figure out how to get the entire row into the array.
r = listrow
rr = listrows
YES, I know a looping redim sucks.
SpecialCells(xlCellTypeVisible)
doesnt work either because it stops at the first hidden row/column.
I may just dump the entire table into the array and then filter the array. I havent figured out how to pull the active filter from the table to apply it, but I havent looked deeply into that yet. Thats what I will be doing now, because I am stuck for the other way.
Any and all advice is welcome.
DM
To avoid REDIM or double loops you can use something like Application.WorksheetFunction.Subtotal(3, Range("A2:A500000")) to quickly count the number of visible rows.
See this question
I define my Target range using .SpecialCells(xlCellTypeVisible). Target.Cells.Count / Target.Columns.Count will give you the row count. Finally I iterate over the cells in the Target range incrementing my counters based off of the Target.Columns.Count.
Public Sub FilteredArray()
Dim Data As Variant, r As Range, Target As Range
Dim rowCount As Long, x As Long, y As Long
Set Target = WorkSheets("Sheet1").ListObjects("Table1").DataBodyRange.SpecialCells(xlCellTypeVisible)
If Not Target Is Nothing Then
rowCount = Target.Cells.Count / Target.Columns.Count
ReDim Data(1 To rowCount, 1 To Target.Columns.Count)
x = 1
For Each r In Target
y = y + 1
If y > Target.Columns.Count Then
x = x + 1
y = 1
End If
Data(x, y) = r.Value
Next
End If
End Sub
The code below will create an array for all the rows and store each of these into another array that will store all info in sheet:
Function RowsToArray()
Dim lastRow: lastRow = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim lastCol: lastCol = ActiveWorkbook.ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Dim newArr()
ReDim newArr(lastRow)
For r = 0 To lastRow - 1
Dim rowarr()
ReDim rowarr(lastCol)
For c = 0 To lastCol - 1
rowarr(c) = Cells(r + 1, c + 1).Value
Next c
newArr(r) = rowarr
Next r
End Function
Can you loop over the cells in rr rather than the rows? If so, as #SJR says, you can only Redim Preserve the final dimension, so we're going to have to switch your dimensions. You can then use r.EntireRow.Hidden to check if we're in a visible row and increase the bound of your array by one if we are.
The following assumes that your data starts in column A:
For Each r In rr
If Not r.EntireRow.Hidden Then
If r.Column = 1 Then
If UBound(testArr, 2) = 0 Then
ReDim testArr(1 To 23, 1 To 1)
Else
ReDim Preserve testArr(1 To 23, 1 To UBound(testArr, 2) + 1)
End If
End If
testArr(r.Column, UBound(testArr, 2)) = r
End If
Next r
Edit:
Alternatively, you can keep using ListRows, but loop through twice, once to set the bounds of your array, and once to fill the array (which will have its own internal loop to run through the row...):
For Each r In rr
If Not r.Range.Height = 0 Then
Fnum = Fnum + 1
ReDim testArr(1 To Fnum, 1 To 3)
End If
Next r
Fnum = 0
For Each r In rr
If Not r.Range.RowHeight = 0 Then
Fnum = Fnum + 1
dumarray = r.Range
For i = 1 To 3
testArr(Fnum, i) = dumarray(1, i)
Next i
End If
Next r
Thanks all, a combo of answers led me to: (not very elegant, but quick)
For Each r In rr
If Not r.Range.Height = 0 Then
TNum = TNum + 1
End If
Next r
ReDim testArr(TNum, 23)
For Each r In rr
If Not r.Range.Height = 0 Then
FNum = FNum + 1
For i = 1 To 23
testArr(FNum, i) = r.Range.Cells(, i)
Next i
End If
Next r
I'm trying to find an index of the minimum value from sum(3) array. And it should be assigned to a variable min
min = index of minimum value
Should I sort the array first or is there any direct way of doing it?
Here is my code:
`Sub Min_index()
Dim Pt_array(3) As Single
Pt_array(0) = 0
Pt_array(1) = 12.3
Pt_array(2) = 16.06
Pt_array(3) = 20.11
Dim Ad_E_array(3) As Single
Dim Lo_E_array(3) As Single
Dim Bs_temp As Single
Dim i As Integer
i = 0
Do While i < 4
Bs_temp = BS
Ad_E_array(i) = Ad_E 'defined in previous Sub
Lo_E_array(i) = Lo_E 'defined in previous Sub
If Bs_temp + Pt_array(i) - Qth < BS_Maximum_limit Then
Bs_temp = Bs_temp + Pt_array(i) - Qth
Ad_E_array(i) = Ad_E_array(i) + 0
Lo_E_array(i) = Lo_E_array(i) + 0
Call function_decide(int_forecast_hour - 1, Bs_temp, Qth + 1, Lo_E_array(i), Ad_E_array(i))
Else
Lo_E_array(i) = Pt_array(i) - Qth - (BS_Maximum_limit - Bs_temp)
Bs_temp = BS_Maximum_limit
Call function_decide(int_forecast_hour - 1, Bs_temp, Qth + 1, Lo_E_array(i), Ad_E_array(i))
End If
i = i + 1
Loop
Dim sum(3) As Single
Dim min As Single
i = 0
Do While i < 4
sum(i) = Abs(Lo_E_array(i)) + Abs(Ad_E_array(i))
i = i + 1
Loop
End Sub`
You can receive the 1-based index position of the element containing the minimum value with the an Excel Application object's use of the worksheet's MIN function and MATCH function.
Sub wqewuiew()
Dim Pt_array(3) As Single, p As Long
Pt_array(0) = 1000
Pt_array(1) = 12.3
Pt_array(2) = 16.06
Pt_array(3) = 20.11
p = Application.Match(Application.Min(Pt_array), Pt_array, 0)
Debug.Print p '<~~ 'p' is 2 (I changed the value of the first array element)
End Sub
I am putting data in my array I created in VBA.
I wrote some formulas in the macro but when I paste them it is not working.
Sub Button3_Click()
Application.Calculation = xlManual
'update list of document
'declare variables
Dim i As Long
Dim m As Long
Dim n As Long
Dim j As Long
Dim lNumColumn As Long
Dim XLsheetD As String
Dim range_data As String
Dim tab_data()
Dim Data As ListObject
Dim track_list As ListObject
'ini Data
Set Data = Sheets("track_list").ListObjects("sheets_list")
Set track_list = Sheets("track_list").ListObjects("track_list")
Application.Goto Reference:=track_list
Column = ActiveCell.Column
Row = ActiveCell.Row - 1
range_data = "A9:A6000"
'import list
m = Data.ListRows.Count
nb_docs_prev = 0
n = 0
lNumColumn = Application.CountA(Sheets("track_list").Range("B6:Z6"))
For k = 1 To lNumColumn
If Range("B6").Offset(0, k - 1) = "manual" Then
GoTo nextcol
End If
n = 0
For i = 1 To m
XLsheetD = Data.DataBodyRange(i, 1)
lNumCases = Application.CountA(Sheets(XLsheetD).Range(range_data))
nb_docs = lNumCases - 1
c = Data.DataBodyRange(i, k + 1)
If c = "-" Then
n = n + lNumCases
GoTo nextsheet
End If
If k = 1 Then
ReDim Preserve tab_data(lNumColumn, nb_docs + nb_docs_prev + 1)
End If
For j = 0 To nb_docs
If Range("B6").Offset(0, k - 1) = "hyperlink" Then
tab_data(k - 1, n) = ""
Else
tab_data(k - 1, n) = Sheets(XLsheetD).Range("A9").Offset(j, c - 1)
End If
n = n + 1
Next j
nb_docs_prev = nb_docs + nb_docs_prev + 1
nextsheet:
Next i
nextcol:
Next k
'Put data in order
lNumCases = track_list.ListRows.Count
'==>test if data already in the table
For p = 1 To n
For q = 1 To lNumCases
If track_list.DataBodyRange(q, 1) = tab_data(0, p - 1) Then
For r = 1 To lNumColumn
If Range("B6").Offset(0, r - 1) = "manual" Or Range("B6").Offset(0, r - 1) = "semi-automatic" Then
If tab_data(r - 1, p - 1) <> "" Then
Else
tab_data(r - 1, p - 1) = track_list.DataBodyRange(q, r).Formula
End If
End If
Next r
End If
Next q
Next p
' formulas for new lines
For p = 1 To n
tab_data(5 - 1, p - 1) = "=IF([#[DCN no]]<>"""",INDEX(DCN!R9C3:R229C3,MATCH([#[DCN no]],DCN!R9C1:R229C1,0)),"""")"
tab_data(11 - 1, p - 1) = "=IF([#[DCN no]]<>"""",IF(INDEX(DCN!R9C7:R229C7,MATCH([#[DCN no]],DCN!R9C1:R229C1,0))<>"""",""CLOSED"",""OPEN""),"""")"
Next p
'paste list
Application.Goto Reference:=track_list
Selection.ClearContents
track_list.Resize Range(Cells(Row, Column), Cells(Row + n, Column + track_list.ListColumns.Count - 1))
Application.Goto Reference:=track_list
Selection = Application.Transpose(tab_data())
Application.Calculation = xlAutomatic
End Sub
Do you know why ?
Before doing that my macro was working. It is just those formulas impossible to paste.
Thanks
Your statement
Range("S8:AY250") = Application.Transpose(tab_data())
Can only be used to write the values of tab_data to the worksheet
You need to explicitly write your array formula to the worksheet via the method Bruce Wayne identified.
Range("S8").formulaArray = "=IF([#[DCNno]]<>"""",INDEX(DCN!R9C3:R229C3,MATCH([#[DCNno]],DCN!R9C1:R229C1,0)),"""")"
Will get you closer to where you want to be, but the above cell reference is undoubtedly wrong, and I can't determine which cell you actually need, since you're using variables in your array elements
I have read through the examples on Stackoverflow and still can't seem to get this statement right - can anyone point me to where I am going wrong please?
The error is a type mismatch at the point where I am trying to split the line of text held in LineText into a multidimensional array Orders(). I tried from RawOrders(j) to Orders(y, x) but same result.
Dim RawOrders() As String
Dim Orders() As String
Dim LineText As String
Dim h As Integer
Dim p As Integer
Dim x As Integer
Dim y As Integer
Dim j As Integer
Dim FilePath As String
Dim FileName As String
Dim FileNum As Integer
FileNum = FreeFile()
Open FileName For Input As #FileNum
RawOrders = Split(Input$(LOF(FileNum), #FileNum), vbNewLine)
Close #FileNum
ReDim Orders(3, 21)
h = 1
p = 0
j = 0
x = 0
y = 0
Do While Not RawOrders(p) = ""
LineText = RawOrders(h)
Do While j <> 21
Orders(y, x) = Split(LineText, ",") *Errors out here giving Type MissMatch*
x = x + 1
j = j + 1
Loop
y = y + 1
h = h + 1
p = p + 1
Loop
Dim splitRes() as Variant 'one dimension
Dim orders()
splitRes = yoursplitfunction
ReDim Orders(3, 21)
Do While j <> 21
Orders(y, x) = splitRes(j) 'guessing that you have 21 values in your lineText
'if you have less you get an error
x = x + 1
j = j + 1
Loop
This is what I got to after changing the Orders() to a variant.
Dim Count As Integer
Dim RawOrders() As String
Dim Orders() As Variant
Dim y As Integer
Dim h As Integer
FileNum = FreeFile()
Open FileName For Input As #FileNum
RawOrders = Split(Input$(LOF(FileNum), #FileNum), vbNewLine)
Close #FileNum
Count = UBound(RawOrders, 1)
ReDim Orders(Count - 1)
h = 1
y = 0
Do While Not RawOrders(h) = ""
Orders(y) = Split(RawOrders(h), ",")
y = y + 1
h = h + 1
Loop