I have Integer values in a 3x3 matrix in the range B2:D4.
I made a nested loop checking each cell until it found an empty one (stop condition for each line read).
I can read the values from each cell and store at the positions of the vector, but when I check the values contained in the vector, only the value of the last position of the vector is displayed.
I need to get all the values to a subroutine that will work with these small vectors.
Option Explicit
Option Base 1
Sub Main()
Dim vet(1 to 3) As Variant
Dim lin As Long
Dim col As Long
Dim i As Long
Sheets("Sheet1").Select
lin = 2
col = 2
i = 1
Cells(lin, col).Activate
Do Until Cells(lin, 1) = ""
col = 2
Do Until Cells(lin, col) = ""
Cells(lin, col).Select
vet(i) = Cells(lin, col).Value
col = col + 1
Loop
' At this point, when checking the vector, only contains the last value
Call showVet(vet())
lin = lin + 1
Loop
End Sub
Sub showVet(ByRef v() As Variant)
Dim i As Long
For i = 1 To 3
Debug.Print (v(i))
Next i
' And at this point, only the last value that was passed ...
End Sub
Look at this:
Option Base 1
Sub Main()
Dim vet(1 To 3) As Variant
Dim lin As Long
Dim col As Long
Dim i As Long
With Sheets("Sheet1")
lin = 2
Do Until Cells(lin, 1) = ""
i = 1
col = 2
Do Until Cells(lin, col) = ""
.Cells(lin, col).Select
vet(i) = Cells(lin, col).Value
i = i + 1
col = col + 1
Loop
Call showVet(vet())
lin = lin + 1
Loop
End With
End Sub
Sub showVet(ByRef v() As Variant)
Dim i As Long
For i = 1 To 3
Debug.Print (v(i))
Next i
End Sub
Related
Trying to create a row range/list that stores all the row numbers with values in column A.
When I run the code I get the last VarRow() -> last row number instead of the entire range/list.
Many times, I could not run through VarRow(VarCount) = z + 1.
It stops at the row when the cell has the value so I cannot finish going to the next line of code (shows Subscript out of range).
Dim VarRow() As Double
VarCount = 0
VarCount2 = 0
For z = 1 To 350
If Range("A1").Offset(z, 0).Value <> 0 Then
VarCount = VarCount + 1
End If
Next z
ReDim Preserve VarRow(VaCount2)
For z = 1 To 350
If Range("A1").Offset(z, 0).Value <> 0 Then
VarCount2 = VarCount2 + 1
VarRow(VarCount) = z + 1
End If
Next z
Loop Through the Rows of a One-Column Range
Option Explicit
Sub RowNumbersToArray()
Const fRow As Long = 2
Const Col As String = "A"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim RowNumbers() As Long
Dim r As Long
Dim n As Long
For r = fRow To lRow
If ws.Cells(r, Col).Value <> 0 Then
ReDim Preserve RowNumbers(0 To n)
RowNumbers(n) = r
n = n + 1
End If
Next r
For n = 0 To n - 1
Debug.Print n, RowNumbers(n)
Next n
End Sub
I am trying to replicate what a Data Table does in excel in VBA. I have got the code working as I want thus far however when I copy data out of the temporary storage array it is offset by 1 Column and 1 Row.
I cannot figure out what the issue is? Thanks in advance.
Sub DataTableLoop()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim CodeRng As Range
Dim PasteRng As Range
Dim WatchRng As Range
Dim ResultRng As Range
Dim ResultRes As Range
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim Count As Integer
Dim col As Integer
Dim MyArray As Variant
Dim TempArr As Variant
Dim CodeVar As Range
Set CodeRng = Worksheets("OptionCodes").[CodeTop]
Set PasteRng = Worksheets("OptionCodes").[OptionsCode]
Set WatchRng = Worksheets("OptionCodes").[WatchRange]
Set ResultRng = Worksheets("OptionCodes").[ResultsRange]
col = WatchRng.Columns.Count
x = Worksheets("OptionCodes").[Iterations].Value
y = x - 1
i = 0
Set ResultRes = ResultRng.Resize(x)
ReDim MyArray(x, col)
Do While i <= y
Set CodeVar = CodeRng.Offset(i, 0)
Count = i + 1
Application.StatusBar = "Iteration: " & Count & " of " & x
CodeVar.Copy
PasteRng.PasteSpecial Paste:=xlPasteValues
Application.Calculate
TempArr = WatchRng
For j = 1 To col
MyArray(Count, j) = TempArr(1, j)
Next j
i = i + 1
Loop
ResultRes = MyArray
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Redim is by default 0 based, so your array is actually 1 row and column larger than you expect. To get 1 based you need to specify the lower bounds
ReDim MyArray(1 To x, 1 To col)
I have a problem where I have created an Array with variables and I want to enter the values in my Array in a separate column which does not match the row index of my Array.
I want to loop through a column and I want to return a value from an Array which does not correspend with the row index of the column. That could for example be to return the first value of my Array on the sixth row.
I Think that my problem probably lies in that I don't know how to set up the nested loop.
Many thanks for any help
I have created my Array like this
Sub arraytest()
Dim MonthArray() As String
Dim Lastrow As Long
Dim StartRow As Byte
StartRow = 2
Dim r As Byte
Lastrow = Range("B" & StartRow).CurrentRegion.Rows.count
If Lastrow > 0 Then
ReDim MonthArray(StartRow To Lastrow)
For r = StartRow To Lastrow
MonthArray(r) = Range("C" & r).Value
Next r
End If
End Sub
So if I have the values in my Array
MonthArray()
Month 1
Month 2
Month 3
Month 4
Month 5
Month 6
Then a simple loop without taking into account row index would be
For i = StartRow To Lastrow
If (Cells(i, "A").Value = "USA:" or Cells(i, "A").Value = "EU:") Then _
Cells(i, "B").Value = " " Else Cells(i, "B").Value = MonthArray(i) <<<
Next i
This would return a table in this order
1 USA:
2 Data MonthArray(2)
3 Data MonthArray(3)
4 EU:
5 Data MonthArray(5)
6 Data MonthArray(6)
But I need the array to be returned like this:
1 USA:
2 Data MonthArray(1)
3 Data MonthArray(2)
4 EU:
5 Data MonthArray(3)
6 Data MonthArray(4)
So, in this case, I want to add the value from my Array if the value in the A column is not USA or EU
What I have tried is this
r = 1
For i = StartRow To Lastrow
If (Cells(i, "A").Value = "USA" or Cells(i, "A").Value = "EU") Then _
Cells (i, "B").Value = " " Next i Else Cells(i, "B").Value = MonthArray (r) <<<
r = r + 1
Next i
However, I want
r = r + 1
To occur only if (Cells(i, "A").Value = "USA" or Cells(i, "A").Value = "EU")
Any help is highly appreciated
If you have a contiguous range for your MonthArray, don't worry about looping and just use:
Dim MonthArray() As Variant, StartRow as Long, LastRow as Long
StartRow = 2
Lastrow = Cells(StartRow, "B").CurrentRegion.Rows.count
MonthArray = Range(Cells(StartRow, "C"), Cells(LastRow, "C")).Value
Then we move into using the array, like your code indicates:
Dim r as Long, i as Long
r = 1
For i = StartRow To Lastrow
If UCase(Cells(i, "A").Value) = "USA" or UCase(Cells(i, "A").Value) = "EU" Then
Cells(i, "B").Value = " "
Else
Cells(i, "B").Value = MonthArray(r,1)
r = r + 1
End If
Next i
Need your r = r+1 in the loop as you move down.
Edit1:
Make sure to add in Sheet references. Assumption made from my testing, where I don' want to be overwriting my cells in B if I determine LastRow based on col B, e.g.:
With Sheets("MonthSource")
Dim MonthArray() As Variant, StartRow as Long, LastRow as Long
StartRow = 2
Lastrow = .Cells(StartRow, "B").CurrentRegion.Rows.count
MonthArray = .Range(.Cells(StartRow, "C"), .Cells(LastRow, "C")).Value
End With
With Sheets("Destination")
Dim r as Long, i as Long
r = 1
For i = StartRow To Lastrow
If UCase(.Cells(i, "A").Value) = "USA" or UCase(.Cells(i, "A").Value) = "EU" Then
.Cells(i, "B").Value = " "
Else
.Cells(i, "B").Value = MonthArray(r,1)
r = r + 1
End If
Next i
End With
Something like this should work for you:
Sub tgr()
Dim ws As Worksheet
Dim MonthArray() As Variant
Dim StartRow As Long
Dim LastRow As Long
Dim i As Long, r As Long
'Always fully qualify workbook and worksheet you're working with, change this as necessary
Set ws = ActiveWorkbook.ActiveSheet
StartRow = 2
LastRow = ws.Cells(StartRow, "B").CurrentRegion.Rows.Count
'Load the values of column C into an array directly, no loop required
With ws.Range(ws.Cells(StartRow, "C"), ws.Cells(LastRow, "C"))
If .Row < StartRow Then Exit Sub 'No data
If .Cells.Count = 1 Then
'Only a single value found in column C, force array type by manually redimming and adding the value
ReDim MonthArray(1 To 1, 1 To 1)
MonthArray(1, 1) = .Value
Else
'Multiple values found in column C, can insert values into array directly
MonthArray = .Value
End If
End With
'Initialize your array index counter variable at 0 to start
r = 0
'Begin loop of rows
For i = StartRow To LastRow
'Check contents of column A
Select Case UCase(Trim(ws.Cells(i, "A").Value))
Case "USA:", "EU:"
'do nothing
Case Else
'increase array index counter variable
r = r + 1
'Output the appropriate array value to column B
ws.Cells(i, "B").Value = MonthArray(r, 1)
End Select
Next i 'advance row counter
End Sub
New to VBA. I'm trying to create an array of rows.
Basically, I have an entire sheet and want to take all the rows that start with a certain value ("MA") in column 8.
I eventually want to manipulate that array (as if it were a range), and paste it somewhere else in the sheet. Can anyone help? Here's my code so far:
Dim top0M As Variant
ReDim top0M(1 To 1) As Variant
For i = 4 To Rows.Count
If Cells(i, 8).Value Like "MA*" Then
top0M(UBound(top0M)) = Rows(i)
ReDim Preserve top0M(1 To UBound(top0M) + 1) As Variant
End If
Next i
This code runs but I'm not sure how to debug it to know if I even have the right rows inside. Can I paste these rows as if they were a range?
This sets the range and loads the whole into an array then it loads a different array with the lines that you want:
With ActiveSheet 'This should be changed to the name of the worksheet: Worksheets("MySheet")
Dim rng As Range
Set rng = .Range(.Cells(4, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(4, .Columns.Count).End(xlToLeft).Column))
Dim tot As Variant
tot = rng.Value
Dim top0M As Variant
ReDim top0M(1 To Application.CountIf(.Range("H:H"), "MA*"), 1 To UBound(tot, 2)) As Variant
Dim k As Long
k = 1
Dim i As Long
For i = LBound(tot, 1) To UBound(tot, 1)
If tot(i, 8) Like "MA*" Then
Dim j As Long
For j = LBound(tot, 2) To UBound(tot, 2)
top0M(k, j) = tot(i, j)
Next j
k = k + 1
End If
Next i
End With
'to print to a sheet just assign the values:
Worksheets("sheet1").Range("A1").Resize(UBound(top0M, 1), UBound(top0M, 2)).Value = top0M
Try this code
Sub Test()
Dim x As Variant
x = ActiveSheet.Range("A4").CurrentRegion.Value
x = FilterArray(x, 8, "MA*", True)
ActiveSheet.Range("K14").Resize(UBound(x, 1), UBound(x, 2)).Value = x
End Sub
Function FilterArray(ByVal myRefArr As Variant, ByVal col As Integer, ByVal refValue As String, ByVal equal As Boolean) As Variant
Dim a As Variant
Dim i As Long
Dim j As Long
Dim n As Long
On Error Resume Next
n = 1
If refValue = "" Then
FilterArray = myRefArr
Else
ReDim a(1 To UBound(myRefArr, 1), 1 To UBound(myRefArr, 2))
For i = 1 To UBound(a, 1)
If IIf(equal, UCase(myRefArr(i, col)) Like UCase(refValue), Not (UCase(myRefArr(i, col)) Like UCase(refValue))) Then
For j = 1 To UBound(a, 2)
a(n, j) = myRefArr(i, j)
Next j
n = n + 1
End If
Next i
a = Application.Transpose(a)
ReDim Preserve a(1 To UBound(a, 1), 1 To n - 1)
a = Application.Transpose(a)
FilterArray = a
End If
On Error GoTo 0
End Function
if i have data filled in worksheet like shown in image, i want to create a 2D array and fill it with data in such way of the selected cells in the image, i.e to take the 1st value and skip the next two values and so on till the end of the array and by same way in columns
i made a solution which delete the intermediate rows and columns but for large array (example of 1000*1000),it takes a lot of time that is why i thought in another way to create array with the above criteria.
this is the code i used for deleting the intermediate rows and columns:
Sub Sorting()
Dim LastRow As Long
LastRow = sh.Range("A1", sh.Range("A1").End(xlDown)).rows.count
For cntr = 1 To LastRow / 3
rows(cntr + 1 & ":" & cntr + 2).EntireRow.Delete
Next
Dim LastColumn As Long
LastColumn = sh.Range("A1").CurrentRegion.Columns.count
K = LastColumn
For cntr = 1 To K / 3
Columns(cntr + 1).EntireColumn.Delete
Columns(cntr + 1).EntireColumn.Delete
Next
End Sub enter code here
Something like this should work for you:
Sub tgr()
Dim ws As Worksheet
Dim aData As Variant
Dim aResults() As Variant
Dim lRow As Long, lCol As Long
Dim i As Long, j As Long
Dim lRowInterval As Long
Dim lColInterval As Long
Set ws = ActiveWorkbook.ActiveSheet
lRowInterval = 3
lColInterval = 3
aData = ws.Range("A1").CurrentRegion
ReDim aResults(1 To Int(UBound(aData, 1) / lRowInterval), 1 To Int(UBound(aData, 2) / lColInterval))
i = 0
For lRow = 1 To UBound(aData, 1) Step lRowInterval
i = i + 1
j = 0
For lCol = 1 To UBound(aData, 2) Step lColInterval
j = j + 1
aResults(i, j) = aData(lRow, lCol)
Next lCol
Next lRow
'Do what you want with the array aResults here
End Sub