I have a 'textbox' (lstDetalhe) in my 'userform' (frmFormDetalhe) and I would like to display only data whose id is the same as ChaveEstrangeira...
Sub Detalhe()
Dim UltimaLinha As Integer
Dim Rng As Range
Dim ChaveEstrangeira As Integer
ChaveEstrangeira = frmForm.lstCarteira.Value
Set Resumo = Sheets("Resumo")
UltimaLinha = [Counta(Resumo!A:A)]
For i = 1 To UltimaLinha
If Sheets("Resumo").Range("B" & i).Value = ChaveEstrangeira Then
frmFormDetalhe.lstDetalhe.ColumnCount = 5
frmFormDetalhe.lstDetalhe.AddItem Sheets("Resumo").Range("C" & i).Value
End If
Next i
End Sub
it turns out that only one column returns to me. How to return multiple columns?
----EDIT---
I did it this way:
Sub Detalhe()
Dim UltimaLinha As Integer
Dim ChaveEstrangeira As Integer
Dim Resumo As Object
Dim i
ChaveEstrangeira = frmForm.lstCarteira.Value
UltimaLinha = [Counta(Resumo!A:A)]
Set Resumo = Sheets("Resumo")
With frmFormDetalhe
.lstDetalhe.ColumnCount = 11
.lstDetalhe.ColumnHeads = False
.lstDetalhe.ColumnWidths = "20;55;50;50;50;60;55;75;50;50"
For i = 2 To UltimaLinha
If Sheets("Resumo").Range("B" & i).Value = ChaveEstrangeira Then
.lstDetalhe.AddItem 'Resumo.Range("A1:K1").Cells(i, 1)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 0) = Resumo.Range("A1:K1").Cells(i, 1)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 1) = Resumo.Range("A1:K1").Cells(i, 2)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 2) = Resumo.Range("A1:K1").Cells(i, 3)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 3) = Resumo.Range("A1:K1").Cells(i, 4)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 4) = Resumo.Range("A1:K1").Cells(i, 5)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 5) = Resumo.Range("A1:K1").Cells(i, 6)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 6) = Resumo.Range("A1:K1").Cells(i, 7)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 7) = Resumo.Range("A1:K1").Cells(i, 8)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 8) = Resumo.Range("A1:K1").Cells(i, 9)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 9) = Resumo.Range("A1:K1").Cells(i, 10)
.lstDetalhe.List(.lstDetalhe.ListCount - 1, 10) = Resumo.Range("A1:K1").Cells(i, 11) 'ERROR HERE
End If
Next i
End With
End Sub
But it seems that this last line is reporting an error ...when I change 10 to a number of 1 just any number it returns without error...
Try this code, please. It is good to create a habit of using Long variables instead of Integer. VBA loads memory with Longs, anyhow and no benefit of using Integer. Since no benefit from memory load point of view, a Long variable offer more space. Then, declare Resumo variable As Worksheet:
Sub Detalhe()
Dim UltimaLinha As Long, ChaveEstrangeira As Long, Resumo As Worksheet
Dim arrList As Variant, i As Long, j As Long, k As Long
Set Resumo = Sheets("Resumo")
ChaveEstrangeira = CLng(frmForm.lstCarteira.value)
UltimaLinha = Resumo.Range("A" & Rows.count).End(xlUp).Row
ReDim arrList(1 To 11, 1 To UltimaLinha)'initial array dim, but with last dimension being rows. Only the last dimension can be ReDim Preserve
For i = 2 To UltimaLinha
If Resumo.Range("B" & i).value = ChaveEstrangeira Then
k = k + 1 'array row to be filled
For j = 1 To 11 'load the array columns for K row
arrList(j, k) = Resumo.Range("A1:K1").Cells(i, j)
Next j
End If
Next i
ReDim Preserve arrList(1 To 11, 1 To k) 'redim the array to the maximum found occurrences
With frmFormDetalhe
.lstDetalhe.ColumnCount = 11
.lstDetalhe.ColumnHeads = False
.lstDetalhe.ColumnWidths = "20;55;50;50;50;60;55;75;50;50;50"'added the eleventh column width
.lstDetalhe.list = WorksheetFunction.Transpose(arrList)
End With
End Sub
Related
When I want to import data using VBA I use following command
Dim FinalArray As Variant
ArrayData = Range("DATA").Value
I also tried doing with the loop, but got error in this place (newData (0, newii))
Dim Data As Variant
Dim newData As Double
Dim i As Long
Data= Range("horiz2").Value
For i= 0 To 11 Step 1
newData (0, newii) = Data(1, i+1)
Next i
When I run this code, I have data stored as Variant/Variant (1 to 1, 1 to 12) type.
At the same time, I notice that while doing some calculations inside the macro, I have a table X where the same values are in Double(0 to 0, 0 to 11) type.
How can I import data from a range in Double format - (Double(0 to 0, 0 to 11) to Variant/Variant (1 to 1, 1 to 12))
How can I transform the table in Double format to Variant (Variant/Variant (1 to 1, 1 to 12) to Double(0 to 0, 1 to 12))?
You will need to loop the arrays to transform them as needed. Here are some helper functions to aid in this endeavor:
Private Function VariantArrayToDoubleArray(ByRef VariantArray As Variant) As Double()
Dim i As Integer
Dim j As Integer
Dim da() As Double
ReDim da(LBound(VariantArray, 1) - 1 To UBound(VariantArray, 1) - 1, _
LBound(VariantArray, 2) - 1 To UBound(VariantArray, 2) - 1)
For i = LBound(VariantArray, 1) To UBound(VariantArray, 1)
For j = LBound(VariantArray, 2) To UBound(VariantArray, 2)
da(i - 1, j - 1) = VariantArray(i, j)
Next
Next
VariantArrayToDoubleArray = da
End Function
Private Function DoubleArrayToVariantArray(ByRef DoubleArray() As Double) As Variant
Dim i As Integer
Dim j As Integer
Dim va() As Variant
ReDim va(LBound(DoubleArray, 1) + 1 To UBound(DoubleArray, 1) + 1, _
LBound(DoubleArray, 2) + 1 To UBound(DoubleArray, 2) + 1)
For i = LBound(DoubleArray, 1) To UBound(DoubleArray, 1)
For j = LBound(DoubleArray, 2) To UBound(DoubleArray, 2)
va(i + 1, j + 1) = DoubleArray(i, j)
Next
Next
DoubleArrayToVariantArray = va
End Function
Here's how to use the helper functions:
Private Sub Test()
Dim va(1 To 1, 1 To 12) As Variant
va(1, 1) = 4
va(1, 2) = 42
va(1, 3) = 52
Dim da() As Double
da = VariantArrayToDoubleArray(va)
Dim va2 As Variant
va2 = DoubleArrayToVariantArray(da)
End Sub
I have a problem with displaying multiple columns in a ListBox in my UserForm.
Everything is working until my numbers of column is max 10.
My code:
Private Sub FindButton_Click()
ListBoxResult.Clear
ListBoxResult.ColumnCount = 14
Dim RowNum As Long
RowNum = 1
Do Until Sheets("db").Cells(RowNum, 1).Value = ""
If InStr(1, Sheets("db").Cells(RowNum, 2).Value, FindDMC.Value, vbTextCompare) > 0 Then
On Error GoTo next1
ListBoxResult.AddItem Sheets("db").Cells(RowNum, 1).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 2) = Sheets("db").Cells(RowNum, 2).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 3) = Sheets("db").Cells(RowNum, 3).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 4) = Sheets("db").Cells(RowNum, 4).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 5) = Sheets("db").Cells(RowNum, 5).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 6) = Sheets("db").Cells(RowNum, 6).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 7) = Sheets("db").Cells(RowNum, 7).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 8) = Sheets("db").Cells(RowNum, 8).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 9) = Sheets("db").Cells(RowNum, 9).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 10) = Sheets("db").Cells(RowNum, 10).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 11) = Sheets("db").Cells(RowNum, 11).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 12) = Sheets("db").Cells(RowNum, 12).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 13) = Sheets("db").Cells(RowNum, 13).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 14) = Sheets("db").Cells(RowNum, 14).Value
ListBoxResult.List(ListBoxResult.ListCount - 1, 15) = Sheets("db").Cells(RowNum, 15).Value
End If
next1:
RowNum = RowNum + 1
Loop
End Sub
ListBoxResult.ColumnCount and properties is 14, also Column widths is ok.
After runing my code the failure code is Run-time error '380': Could not set the List property. Invalid property value. At first, I was thinking that maybe ListBoxes have limits for columns, but I found ListBoxes with 60 columns on the Internet.
I am trying also this, but still doesn't work:
Private Sub Browser_RMA_Initialize()
ListBoxResult.RowSource = "db!a1:z1"
ListBoxResult.ColumnCount = 14
ListBoxResult.ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;"
ListBoxResult.ColumnHeads = True
End Sub
Could you support me, please?
Assigning to .Columnproperty avoids transposing
As late addition to #Dy.Lee 's valid and already accepted array approach (see my comment), I demonstrate a way how to avoid both repeated redimming [4] and transposing [5]:
Option Explicit ' declaration head of UserForm code module
Private Sub FindButton_Click()
'[0] where to search
Const SearchCol As Long = 2 ' get search items from 2nd column
'[1] define data set
Dim data As Variant
data = Tabelle1.Range("A1").CurrentRegion ' << change to your project's sheet Code(Name)
Dim ii As Long: ii = UBound(data, 1) ' row count
Dim jj As Long: jj = UBound(data, 2) ' column count
'[2] provide for sufficient result rows (array with converted row : columns order)
Dim results() As Variant
ReDim Preserve results(1 To jj, 1 To ii) ' redim up to maximum row count ii
'[3] assign filtered data
Dim i As Long, j As Integer, n As Long
For i = 1 To ii
If InStr(1, data(i, SearchCol), FindDMC.Value, vbTextCompare) > 0 Then
'' If data(i, SearchCol) = FindDMC.Value Then ' exact findings
n = n + 1
For j = 1 To jj
results(j, n) = data(i, j)
Next
End If
Next i
'[4] fill listbox with results
With ListBoxResult
.Clear
.ColumnCount = 14
.ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;"
If n Then
'[4] redimension only a 2nd time (& last time)
ReDim Preserve results(1 To jj, 1 To n)
'[5] assign results to listbox'es .Column property
.Column = results ' << .Column property avoids unnecessary transposing
End If
End With
End Sub
The column index of the listbox also starts at 0. The index number of additem should be 0, and you specified 15 at the end, then the number of columns becomes 16, so an error occurs because column 14 is exceeded.
It would be convenient to use an array.
Private Sub FindButton_Click()
Dim Ws As Worksheet
Dim vDB As Variant, vResult()
Dim i As Long, j As Integer, n As Long
Set Ws = Sheets("db")
vDB = Ws.Range("a1").CurrentRegion
For i = 1 To UBound(vDB, 1)
If InStr(1, vDB(i, 2), FindDMC.Value, vbTextCompare) > 0 Then
n = n + 1
ReDim Preserve vResult(1 To 14, 1 To n)
For j = 1 To 14
vResult(j, n) = vDB(i, j)
Next
End If
Next i
With ListBoxResult
.Clear
.ColumnCount = 14
.ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;"
If n Then
If n = 1 Then
.Column = vResult
Else
.List = WorksheetFunction.Transpose(vResult)
End If
End If
End With
End Sub
After populating my arrays based on some criteria I am attempting to write two temporary arrays to two different ranges on the worksheet. Using my current method with the transposed arrays I begin to get #N/A values after row 24,392. I'm not sure how to get past the size limitations of Application.Transpose.
LastRowA and LastRowB are declared globally as long. The value of LastRowA is >11,000 and LastRowB is >80,000
Sub Test()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'call subs to find last rows for each sheet
LastRowASub
LastRowBSub
Dim i As Long
Dim j As Long
Dim x As Double
Dim y As Double
Dim Arr1() As Variant
Dim Arr2() As Variant
Dim Temp1() As String
Dim Temp2() As String
ReDim Arr1(1 To LastRowA - 1, 3)
ReDim Arr2(1 To LastRowB - 1)
ReDim Temp1(1 To LastRowB - 1)
ReDim Temp2(1 To LastRowB - 1)
'populate first array
For x = 1 To LastRowA - 1
Arr1(x, 1) = sheet1.Range("k" & x + 1)
Arr1(x, 2) = sheet1.Range("c" & x + 1)
Arr1(x, 3) = sheet1.Range("a" & x + 1)
Next x
'populate second array
For y = 1 To LastRowB - 1
Arr2(y, 1) = sheet2.Range("f" & y + 1)
Next y
'populate two temporary arrays based on matching between arrays 1 and 2
For i = 1 To UBound(Arr2)
For j = 1 To UBound(Arr1)
If Arr1(j, 1) = Arr2(i, 1) And Not IsEmpty(Arr1(j, 2)) Then
Temp1(i) = Arr1(j, 2)
Temp2(i) = Arr1(j, 3)
End If
Next j
Next i
'write temp arrays to sheet2
sheet2.Range("C2:C" & ExtLRow) = Application.Transpose(Temp1)
sheet2.Range("G2:G" & ExtLRow) = Application.Transpose(Temp2)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Everything is working as expected other than the transposed arrays returning #N/A.
Make the arrays 2 dimensional with one column:
ReDim Temp1(1 To LastRowB - 1,1 to 1)
ReDim Temp1(1 To LastRowB - 1,1 to 1)
Then when you assign the values:
Temp1(i,1) = Arr1(j, 2)
Temp2(i,1) = Arr1(j, 3)
Then you do not need the Application.Transpose
sheet2.Range("C2:C" & ExtLRow) = Temp1
sheet2.Range("G2:G" & ExtLRow) = Temp2
Also to speed things up avoid the loops altogether:
Sub Test()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'call subs to find last rows for each sheet
LastRowASub
LastRowBSub
Dim i As Long
Dim j As Long
Dim x As Double
Dim y As Double
Dim Arr1() As Variant
Dim Arr2() As Variant
Dim Temp1() As Variant
Dim Temp2() As Variant
ReDim Temp1(1 To LastRowB - 1, 1 To 1)
ReDim Temp2(1 To LastRowB - 1, 1 To 1)
'populate first array
Arr1 = Sheet1.Range("A2:K" & lastrowa).Value
'populate second array
Arr2 = sheet2.Range("F2:F" & LastRowB).Value
'populate two temporary arrays based on matching between arrays 1 and 2
For i = 1 To UBound(Arr2, 1)
For j = 1 To UBound(Arr1, 1)
If Arr1(j, 11) = Arr2(i, 1) And Not IsEmpty(Arr1(j, 3)) Then
Temp1(i, 1) = Arr1(j, 3)
Temp2(i, 1) = Arr1(j, 1)
End If
Next j
Next i
'write temp arrays to sheet2
sheet2.Range("C2:C" & ExtLRow).Value = Temp1
sheet2.Range("G2:G" & ExtLRow).Value = Temp2
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
As far as I know, Excel Average functions do not include cells that are blank. However, my this appears to be exactly what my code is doing:
Sub sumavg()
Dim rowCounter As Long
Dim colCounter As Long
Dim values() As Variant
Const START_COL As Long = 1
Const END_COL As Long = 6
Const OUTPUT_COL_START As Long = 20
With Worksheets("datasummary")
'Load the values into an array
values = .Range(.Cells(1, 1), .Cells(199, 18)).Value
For rowCounter = 1 To 40
ReDim rowresults(1 To 1, START_COL To END_COL)
For colCounter = START_COL To END_COL
'find average of AOIentries values
rowresults(1, colCounter) = Application.WorksheetFunction.Average(values((5 * rowCounter - 2), colCounter), values((5 * rowCounter - 2), colCounter + 6), values((5 * rowCounter - 2), colCounter + 12))
Next colCounter
'print row of results
.Range(.Cells(5 * rowCounter - 2, OUTPUT_COL_START), .Cells(5 * rowCounter - 2, OUTPUT_COL_START + END_COL - START_COL)).Value = rowresults
For colCounter = START_COL To END_COL
'find average of RT values
rowresults(1, colCounter) = Application.WorksheetFunction.Average(values((5 * rowCounter - 1), colCounter), values((5 * rowCounter - 1), colCounter + 6), values((5 * rowCounter - 1), colCounter + 12))
Next colCounter
'print row of results
.Range(.Cells(5 * rowCounter - 1, OUTPUT_COL_START), .Cells(5 * rowCounter - 1, OUTPUT_COL_START + END_COL - START_COL)).Value = rowresults
Next rowCounter
End With
End Sub
Here is the code to print values including blank cells:
For r = 1 To UBound(d, 1)
k = d(r, COL_BLOCK) & "|" & d(r, COL_TRIAL) 'create key
If d(r, 19) = 1 Then
dBT(k) = dBT(k) + IIf(d(r, COL_AOI) = "AOI Entry", 1, 0) 'get count
Else: dBT(k) = ""
End If
Next r
'populate array with appropriate counts for each row
For r = 1 To UBound(d, 1)
k = d(r, 1) & "|" & d(r, 2) 'create key
resBT(r, 1) = dBT(k) 'get the count
Next r
Call createsummarytable
Call PopSummaryAOI(dBT)
dBT.RemoveAll
For r = 1 To UBound(d, 1)
k = d(r, COL_BLOCK) & "|" & d(r, COL_TRIAL) 'create key
dBT(k) = d(r, COL_RT)
Next r
As far as I can tell, the cell is entirely blank, so it shouldn't be included in the average, but (20 + 17)/2 =/= 12.33, whereas (20 + 17 + 0)/3 = 12.33.
When you call .Range(.Cells(1, 1), .Cells(199, 18)).Value, you end up with an array of Variant. WorksheetFunction.Average treats Ranges and Variant arrays differently than it treats Variants. If you give it individual Variant for arguments, it casts them to Doubles, and casting Empty to a Double results in 0. If you want it to ignore empty cells, you need to pass it a Range or a Variant():
Sub Example()
Dim test As Variant
test = Empty 'This is what you get from an EmptyCell.Value
Debug.Print CDbl(test) 'Prints 0.
Debug.Print WorksheetFunction.Average(test, 0, 10) 'Prints 3.33333333333333.
Range("A1").ClearContents 'Nothing in A1 now.
Debug.Print Range("A1").Value = Empty 'Prints True
Debug.Print WorksheetFunction.Average(Range("A1"), 0, 10) 'Prints 5
End Sub
I am trying parse a number string and create rows accordingly. On the left of the Example Data picture is an example of the input data with the right being my desired output. I am wanting to insert a unique row of data for each digit within the brackets for each number combination.
Here is an example of the code I used to try to solve the problem.
Option Explicit
Sub example()
Dim num As Variant
Dim x As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim test As Variant
Dim test2 As Variant
Dim count As Integer
m = 0
For i = 1 To 3
num = Range("C" & 5 + i + m).Value
For j = 1 To Len(num)
test = Mid(num, j)
If Left(Mid(num, j), 1) = "[" Then
For k = 1 To Len(num) - (j + 1)
m = m + 1
Range("C" & 5 + m + i - 1).EntireRow.Insert
test2 = Left(Mid(num, j + k), 1)
Range("C" & 5 + m + i - 1).Value = Left(num, j - 1) + test2
Next k
End If
Next j
Next i
End Sub
Please consider using the following script:
Sub splitcombinations()
Dim rngCell As Range
Set rngCell = ThisWorkbook.Sheets(1).Range("A2")
Dim strCombinationDigits As String, strBaseDigits As String
Dim intCombinationDigitsLen As Integer
Dim x As Integer
Do While rngCell.Value2 <> ""
If InStr(rngCell.Value2, "[") > 0 Then
strCombinationDigits = Mid(rngCell.Value2, InStr(rngCell.Value2, "[") + 1, InStr(rngCell.Value2, "]") - InStr(rngCell.Value2, "[") - 1)
intCombinationDigitsLen = Len(strCombinationDigits)
strBaseDigits = Left(rngCell.Value2, InStr(rngCell.Value2, "[") - 1)
ActiveSheet.Range(rngCell.Offset(1, 0), rngCell.Offset(intCombinationDigitsLen - 1, 0)).EntireRow.Insert
For x = 1 To intCombinationDigitsLen
rngCell.Offset(x - 1, 0).Value2 = strBaseDigits & Mid(strCombinationDigits, x, 1)
rngCell.Offset(x - 1, 1).Value2 = rngCell.Offset(0, 1).Value2
rngCell.Offset(x - 1, 2).Value2 = rngCell.Offset(0, 2).Value2
Next
End If
Set rngCell = rngCell.Offset(intCombinationDigitsLen , 0)
Loop
End Sub