I have the following code which loop through all the cells of the selected row. How to store all the values in an array?
Dim selectedCellCount As Integer = dgvData.GetCellCount(DataGridViewElementStates.Selected)
Dim RowVal As String
Dim i As Integer
For i = 0 To selectedCellCount - 1
RowVal = dgvData.SelectedCells(i).Value.ToString
Next i
End Sub
There is two method one with list another with array
1- List
Dim selectedCellCount As Integer = dgvData.GetCellCount(DataGridViewElementStates.Selected)
Dim RowVal As String
Dim i As Integer
Dim list As New List(Of string)
For i = 0 To selectedCellCount - 1
RowVal = dgvData.SelectedCells(i).Value.ToString
list.Add(RowVal)
Next i
End Sub
2- Array
Dim selectedCellCount As Integer = dgvData.GetCellCount(DataGridViewElementStates.Selected)
Dim RowVal As String
Dim i As Integer
Dim arrayOfData(selectedCellCount - 1) As String
For i = 0 To selectedCellCount - 1
RowVal = dgvData.SelectedCells(i).Value.ToString
arrayOfData(i) = RowVal
Next i
End Sub
Check out a List(of string). The list is easier to use than any other type of array. Here is a good explanation:
https://www.dotnetperls.com/list-vbnet
Related
I have code to ask a user for a series of codes that then creates a single-dimensional array like this:
Dim strDaysTimes As String
Dim arrDaysTimes() As String
strDaysTimes = InputBox("What days and times do you want to schedule meetings for? (write as 6c,7b)", "Enter Days and Times")
arrDaysTimes() = Split(strDaysTimes, ",")
The number of inputs is not defined but the format is. It could be "6c,7b" or "5a,6b,7b".
I want to convert this into a multi-dimensional array that would carry the values like this (one dimension has the number portion and the other has the letter portion):
5 a
6 b
7 b
I know that I need to use a nested For...Next statements to process multidimensional arrays, but I would appreciate any suggestions.
Use ReDim:
Public Function DivideArray()
Dim strDaysTimes As String
Dim arrDaysTimes() As String
Dim DaysTimes() As String
Dim Index As Integer
strDaysTimes = InputBox("What days and times do you want to schedule meetings for? (write as 6c,7b)", "Enter Days and Times")
arrDaysTimes() = Split(strDaysTimes, ",")
ReDim DaysTimes(UBound(arrDaysTimes) - LBound(arrDaysTimes) + 1, 0 To 1)
For Index = LBound(arrDaysTimes) To UBound(arrDaysTimes)
DaysTimes(Index, 0) = Left(LTrim(arrDaysTimes(Index)), 1)
DaysTimes(Index, 1) = Right(RTrim(arrDaysTimes(Index)), 1)
Next
For Index = LBound(arrDaysTimes) To UBound(arrDaysTimes)
Debug.Print DaysTimes(Index, 0), DaysTimes(Index, 1)
Next
End Function
Input example:
a7, b8, c9
Output:
a 7
b 8
c 9
Just for the sake of the art an alternative to #Gustav 's approach with the bonus that it returns token lengths greater than 1, too.
Furthermore it profits from the fact that the Val() function is able to return
a) the starting numeric value from an input string and
b) the closing string by a split via the above numeric value as delimiter.
Public Function tokenize(ByVal s As String)
Dim arr() As String
arr() = Split(Trim(s), ",")
Dim tmp() As String
ReDim tmp(0 To UBound(arr) - LBound(arr), 0 To 1)
Dim i As Long
For i = LBound(arr) To UBound(arr)
Dim num: num = Val(arr(i))
tmp(i, 0) = num
tmp(i, 1) = Split(arr(i), num)(1)
Next
tokenize = tmp
End Function
Example call
Sub testTokenize()
'0. Get input string (e.g. "6c,7b")
Dim strDaysTimes As String
strDaysTimes = InputBox( _
"What days and times do you want to schedule meetings for? (write as 6c,7b)", _
"Enter Days and Times", _
"6c,7b")
'1. Call help function
Dim results As Variant
results = tokenize(strDaysTimes) ' << function tokenize()
'2. Show results in VB Editor's immediate window
Dim i As Long
For i = LBound(results) To UBound(results)
Debug.Print results(i, 0), results(i, 1)
Next
End Sub
The following code will help you get there.
The GetDaysAndTimes function will return a Jagged array (i.e. an array of arrays). This means that to get the Day and Time of Item 3 you would use ArrayName(2)(0) and ArrayName(2)(1) where arrayname is the name of the array you are using (arrayDaysTimes?)
The function SplitAlphaNumString allows users to enter codes such as AB23.
Option Explicit
' This function takes the string returned by your input box
Public Function GetDaysAndTimes(ByRef ipString As String) As Variant
Dim myItems As Variant
myItems = VBA.Split(ipString, ",")
Dim myDayTimes As Variant
Dim myindex As Long
For myindex = LBound(myItems) To UBound(myItems)
myDayTimes(myindex) = SplitAlphaNumString(myItems(myindex))
Next
GetDaysAndTimes = myDayTimes
End Function
Public Function SplitAlphaNumString(ByVal ipString As String) As Variant
Dim myindex As Long
For myindex = 1 To VBA.Len(ipString)
If VBA.Asc(VBA.Mid(ipString, myindex, 1)) < 58 Then
Dim myAlphas As String
myAlphas = VBA.Mid(ipString, 1, myindex - 1)
Dim myNums As String
myNums = VBA.Mid(ipString, myindex)
SplitAlphaNumString = Array(myAlphas, myNums)
Exit Function
End If
Next
End Function
Sub Test()
Dim myArray As Variant
myArray = SplitAlphaNumString("D5")
Debug.Print myArray(0), myArray(1)
End Sub
Have a 2d Array, need to search through one of the columns finding a string and deleting everything after it.
I have a list of dates, but the format it is currently in has a long Time value
after the date ending in 2019. I would like to find and replace 2019 + time
with just 2019.
Edit code
The date isn't stored as a date, for all intents and purposes it's a string that looks something like "****#### 2019 ######" and I am just looking for a method to remove everything after a value, (2019) .
Right now, it steps through it all nicely checks array value by value
but doesn't actually change anything.
Edit2
Found workable solution using Instr & Split functions.
BUT the weirdest bug crept in,
some dates appear fine in debug.print
eg : 11/06/2019 BUT after printing to a range 06/11/2019
13/06/2019 13/06/2019
Even if the format of the destination is pre-defined
Public Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End Sub
Private Sub Test()
Dim Name_col As Integer
Dim Date_col As Integer
Dim Hours_col As Integer
Dim Department_col As Integer
Dim Data_row As Integer
Name_col = 1
Date_col = 2
Hours_col = 3
Department_col = 4
Data_row = 2
Dim i As Integer
Dim zom As Integer
Dim DirArray As Variant
Dim col As Integer
Dim LString As String
Dim LArray() As String
zom = 0
i = 2
col = 2
Dim X As Integer
Application.ScreenUpdating = False
Do While Sheets("Sheet2").Cells(i, 1).Value <> ""
i = i + 1
zom = zom + 1
Loop
Application.ScreenUpdating = True
NumberOfZombies = zom
Debug.Print "Number of zombies" & NumberOfZombies
Worksheets("Sheet2").Activate
DirArray = Sheets("Sheet2").Range(Cells(Data_row, Name_col), Cells(zom, Department_col)).Value
For rw = LBound(DirArray) To UBound(DirArray)
For col = LBound(DirArray) To UBound(DirArray, 2)
LString = DirArray(rw, col)
If InStr(LString, "2019") > 0 Then
LArray = Split(LString)
Debug.Print LArray(0)
DirArray(rw, col) = LArray(0)
End If
Debug.Print DirArray(rw, col)
Next
Next
PrintArray DirArray, Sheets("Sheet3").[A1]
End Sub
I'm trying to run through a column of values, compare it to a supplied string, if it matches the string, add the value 4 columns over into an array, then sum the array at the end of the function.
The function exits out (not fails) at the ReDim Preserve line.
If I comment that out, it fails at the SumArray(Count) line.
What am I missing?
'Function used to SUM
Public Function TotalSum(prefix As String, rng As Range) As Integer
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim SumArray As Variant
Dim Count As Long
Dim cell As Range
Dim i As Integer
Count = 0
For Each cell In rng
If Left(cell.Value, 7) = prefix Then
If Not BookofDaveSum.Exists(cell.Value2) Then
BookofDaveSum.Add cell.Value2, 0
ReDim Preserve SumArray(0 To Count)
SumArray(Count) = cell.Offset(0, 4)
Count = Count + 1
End If
End If
Next cell
TotalSum = Application.WorksheetFunction.Sum(SumArray)
End Function
Since you are iterating the range you are not gaining anything by using the array. Simply keep a running total:
Public Function TotalSum(prefix As String, rng As Range) As Integer
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim cell As Range
For Each cell In rng
If Left(cell.Value, 7) = prefix Then
If Not BookofDaveSum.Exists(cell.Value2) Then
TotalSum = TotalSum + cell.Offset(0, 4).Value2
End If
End If
Next cell
End Function
If your concern is speed then convert both ranges to arrays and iterate the array:
Public Function TotalSum(prefix As String, rng As Range) As Long
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim chRng As Variant
chRng = rng.Value2
Dim addRng As Variant
addRng = rng.Offset(, 4).Value2
Dim temp As Long
temp = 0
Dim i As Long
For i = LBound(chRng, 1) To UBound(chRng, 1)
If Left(chRng(i, 1), 7) = prefix Then
If Not BookofDaveSum.Exists(chRng(i, 1)) Then
temp = temp + addRng(i, 1)
End If
End If
Next cell
TotalSum = temp
End Function
Also this can be done with a formula:
=SUMPRODUCT(((LEFT(A1:A10,7)="abcdefg")*(E1:E10))/(COUNTIFS(A1:A10,A1:A10,A1:A10,"abcdefg" &"*")+(LEFT(A1:A10,7)<>"abcdefg")))
Where abcdefg is your prefix, A1:A10 is the string to test and E1:E10 the values to add
Dim SumArray() As Variant you are trying to redim a variable not an array. () indicates you want an array of variants.
I need a public function to get array and counts values in specific column.
I wrote the following and recives subscription out of range message.
Public Function CountUarrcol(inarr() As Variant, colidx As Integer) As Long
Dim col As New Collection
Dim i As Integer
Dim element As Variant
For i = 0 To UBound(inarr, colidx)
For Each element In inarr(i + 1, colidx)
col.Add Item:=CStr(element.value), Key:=CStr(element.value)
Next
Next i
CountUarrcol = col.Count End Function
Assuming you want to do a count of distinct values within a specified column of an array, here is an example with a 5*3 array read in from a worksheet range, counting the distinct values in column 2. I am using a function by Mark Nold to check if the value to be added already exists in the collection.
Option Explicit
Public Sub test()
Dim testArr()
Dim myCount As Long
testArr = ActiveSheet.Range("A1:C5").Value
myCount = CountUarrcol(testArr, 2)
MsgBox myCount
End Sub
Public Function CountUarrcol(inarr() As Variant, colidx As Long) As Long
Dim col As New Collection
Dim i As Long
For i = 1 To UBound(inarr)
If Not InCollection(col, CStr(inarr(i, colidx))) Then
col.Add Item:=CStr(inarr(i, colidx)), key:=CStr(inarr(i, colidx))
End If
Next i
CountUarrcol = col.Count
End Function
'Mark Nold https://stackoverflow.com/questions/137845/determining-whether-an-object-is-a-member-of-a-collection-in-vba
Public Function InCollection(col As Collection, key As String) As Boolean
Dim var As Variant
Dim errNumber As Long
InCollection = False
Set var = Nothing
Err.Clear
On Error Resume Next
var = col.Item(key)
errNumber = CLng(Err.Number)
On Error GoTo 0
'5 is not in, 0 and 438 represent incollection
If errNumber = 5 Then ' it is 5 if not in collection
InCollection = False
Else
InCollection = True
End If
End Function
I Used two sub routine as follow:
Public Function CountUvalinarrcol(ByRef inarr As Variant, ByVal colidx As Integer) As Long
Dim col As New Collection
Dim i As Integer
Dim element As Variant
For i = 1 To UBound(inarr)
element = inarr(i, colidx)
If colContains(col, element) = False Then
col.Add item:=CStr(element)
End If
Next i
CountUvalinarrcol = col.Count
End Function
The other one is:
Public Function colContains(colin As Collection, itemin As Variant) As Boolean
Dim item As Variant
colContains = False
For Each item In colin
If item = itemin Then
colContains = True
Exit Function
End If
Next
End Function
Calling above functions:
sub test()
dim x as long
x= CountUvalinarrcol(lsarr, 0)
end sub
I am trying to use excel 2010 VBA to populate an array containing three arrays. The first is a string type array and the other two are integer type arrays. The relevant portion of the macro is below.
Option Explicit
Option Base 1
Private Type T_small
myStr() As String
y() As Integer
z() As Integer
End Type
Sub ColorByPoint()
On Error GoTo ErrHandler
Dim I As Integer, SCCount As Integer, PCCount As Integer, CLCount As Integer
Dim N As Integer, M As Integer, K As Integer, P As Integer
Dim x() As String, y() As Integer, z() As Integer
Dim pvtItM As Variant
Dim xName As String, str As String
Dim xlRowField As Range
Dim PC As ChartObjects
Dim WS As Sheet3
Dim SC As SeriesCollection
Dim MyObj As Object
Dim PvTbl As Object
Dim CelVal As Integer
Dim rng As Variant, lbl As Variant, vlu As Variant
Dim ItemField1 As PivotItem, ItemField2 As PivotItem
Dim ValueField As PivotField
Dim dField As PivotCell
Dim oPi As PivotItem
Dim acolRng As Range
Dim arowRng As Range
Dim myStr() As String
Dim iData() As T_small
Dim xSSN() As String
Set WS = Application.ActiveWorkbook.ActiveSheet
Set MyObj = Worksheets("Pivot1").ChartObjects("MyChart").Chart
Set PvTbl = Worksheets("Pivot1").PivotTables("PivotTable1")
Set rng = PvTbl.PivotFields("SSN").PivotItems
Set lbl = PvTbl.DataFields
M = 1
SCCount = MyObj.SeriesCollection.Count 'Series count
PCCount = PvTbl.TableRange1.Rows.Count 'Rows Count
CLCount = PvTbl.TableRange1.Columns.Count 'Columns Count
Set acolRng = PvTbl.ColumnRange
Set arowRng = PvTbl.RowRange
Worksheets("Pivot1").Activate
P = PCCount
ReDim Preserve myStr(P)
ReDim Preserve y(P)
ReDim Preserve z(P)
ReDim Preserve iData(P)
For N = 2 To PCCount
ReDim Preserve iData((iData(2).myStr(2)), (iData(N).y(N)),(iData(N).z(N)))
Next N
For I = 2 To PvTbl.TableRange1.Rows.Count Step 1
For K = 2 To PvTbl.TableRange1.Columns.Count Step 1
M = K
N = K
iData(I).myStr(I) = PvTbl.Cells("myStr" & I, "K").Value
iData(I).y(I) = PvTbl.Cells("I", "M").Value
iData(I).z(I) = PvTbl.Cells("I", "N").Value
Next K
Next I
The problem is that the line
ReDim Preserve iData((iData(2).myStr(2)), (iData(N).y(N)), (iData(N).z(N)))
continues to give me a "Run Time error 9 Subscript out of range" error. I've tried everything I can think of to get past this including using "N"'s instead of the "2" indexes throughout, adding and removing parentheses, etc.
What causes the runtime error?
The problem is you are accessing the array indexes of your T_small properties. You never define (or change) the bounds of iData(x).myStr; rather you only define the bounds of myStr, which is not part of your iData array.
In other words, the of bounds error comes from trying to access iData(x).myStr(x) because iData(x).myStr has no bounds defined.
This should work:
' Now that the iData bounds have been defined, update the property bounds.
ReDim Preserve iData(N).myStr(myStr(N))
ReDim Preserve iData(N).y(y(N))
ReDim Preserve iData(N).z(z(N))
Note that I am having a bit of difficulty following exactly what your code is trying to accomplish, so the above only addresses the specific error you are getting.