can someone help me to understand why i get a runtime error 9 (subscript out of range) from my code?
Dim prod(1 To 6) As String
prod(1) = "001"
prod(2) = "002"
prod(3) = "003"
prod(4) = "004"
prod(5) = "005"
prod(6) = "006"
Dim sum(1 To 6) As Double
For i = 1 to 6 Step 1
sum(i) = 0
Next i
Dim sumA(1 To 12) As Double
For i = 1 To 12 Step 1
sumA(i) = 0
Next i
Sheets("Punching").Activate
LR = Cells(Rows.Count, "G").End(xlUp).Row
For i = 4 To LR Step 1
For j = 1 To UBound(prod) Step 1
If Cells(i, 11) = prod(j) Then
sum(j) = sum(j) + Cells(i, 18).Value
Else
sum(j) = sum(j)
End If
Next j
Next i
For k = 4 To LR Step 1
For l = 1 To UBound(sumA) Step 2
**If Cells(k, 11) = prod(l) Then**
sumA(l) = sumA(l) + Cells(k, 19).Value
sumA(l + 1) = sumA(l + 1) + Cells(k, 20).Value
Else
sum(l) = sum(l)
End If
Next l
Next k
The error line is the asterix line.
Is it because i cannot reuse the array of prod? I dont get it why i get this error.
Any help will be appreciated!
Related
I'm just starting out with VBA and am trying to output an array into a range, but when I set the range to the array, I get blank cells. If I do set the range to a specific index like "titlearray(1, 3)" then it does print the correct output.
This is my full code below..
Sub GenerateList()
baseyr = 2019
mnthct = 1
mnthyr = InputBox("Actuals up to: (xx/xxxx format)")
Sheets("Parameters").Cells(4, 2) = mnthyr
yr = Right(mnthyr, 4)
mnthcols = 12 * (yr - baseyr + 2)
dtarray = Sheet3.Cells(1, 1).CurrentRegion
dtcols = UBound(dtarray, 2) - LBound(dtarray, 2)-1
totalcols = dtcols + mnthcols
ReDim titlearray(1, totalcols)
For i = 1 To totalcols
If i <= dtcols Then
titlearray(1, i) = dtarray(1, i)
Else
titlearray(1, i) = mnthct & "/1/" & baseyr
mnthct = mnthct + 1
If mnthct = 13 Then
baseyr = baseyr + 1
mnthct = 1
End If
End If
Next
'Sheets("Test").Range(Cells(1, 1), Cells(1, totalcols)) = titlearray
End Sub
If i do 'Sheets("Test").Range(Cells(1, 1), Cells(1, totalcols)) = titlearray(1,3), it'll print the correct value.. I feel like this is a really simple mistake but I don't know what it is. Thanks and appreciate your help!
When you Redim an Array, by default it's 0 based (but that can be overridden with Option Base 1)
So, your line
ReDim titlearray(1, totalcols)
is the same as
ReDim titlearray(0 To 1, 0 To totalcols)
Change that to
ReDim titlearray(1 To 1, 1 To totalcols)
So, I want to use 1D and 2D arrays in place of the ranges in formulas, except that whatever I have tried has not worked. If anyone can, can they please help?
Also, when transposing my data, I don't understand how to do this by referencing other sheets.
Sub Testrun()
Cells(5, 6).Value = "=Sum([myArr])"
Set mcco = Workbooks("Book1.xlsb").Worksheets("Sheet1")
Set mcfc = Workbooks("Book1.xlsb").Worksheets("Sheet2")
Set mcfb = Workbooks("Book1.xlsb").Worksheets("Sheet3")
TR = Application.CountA(Range("A:A"))
FTNRowStart = 1
MainRowStart = 2
CVTRRowEnd = mcco.Range("A2", mcco.Range("A2").End(xlDown)).Rows.Count + 1
FCRowEnd = mcfc.Range("A2", mcfc.Range("A2").End(xlDown)).Rows.Count + 1
MNCol = 2
FNCol = 4
FTNCol = 8
CVTRmyArr = Application.Transpose(Range(Cells(MainRowStart, MNCol), Cells(CVTRRowEnd, MNCol)))
FCmyArr = Application.Transpose(Range(Cells(MainRowStart, MNCol), Cells(FCRowEnd, MNCol)))
FNmyArr = Application.Transpose(Range(Cells(MainRowStart, FNCol), Cells(FCRowEnd, FNCol)))
mcfc.Activate
For i = 2 To TR
s = 0
TCJ = Cells(1, Columns.Count).End(xlToLeft).Column + 7
For j = 8 To TCJ
TCK = mcfb.Cells(i, Columns.Count).End(xlToLeft).Column + 1
For k = 2 To TCK
XD = "=COUNTIFS(CVTRmyArr,'Sheet3'!R" & i & "C" & k & ",'Sheet3'!R[0]C" & k & ",FNmyArr,""*"" & SUBSTITUTE(MID(FNmyArr,FIND(""*"",SUBSTITUTE(FNmyArr,""("",""*"",LEN(FNmyArr) - LEN(SUBSTITUTE(FNmyArr,""("","""")))) +1,LEN(FNmyArr)),"")"",""""))"
mcfc.Cells(i, j).Value = XD
s = s + Cells(i, j).Value
Cells(i, j).Value = s
Next k
Next j
Next i
End Sub
I'm trying to use VBA to auto fill (1, 2, 3, ....) in column "A" while skipping rows that are not blank/empty. For example, if there is text/data in "A3" and "A5", the code would count as follows:
"A1" = 1 "B1" = text/data
"A2" = 2 "B2" = text/data
"A3" = text/data "B3" = text/data
"A4" = 3 "B4" = text/data
"A5" = text/data "B5" = text/data
"A6" = 4 "B6" = text/data
"A7" = 5 "B7" = text/data
...and so on
So far I've only been able to skip the rows with previously entered text but that count continues as if it wasn't skipping any cells.
Please Note: I'm using .End(xlDown).Count in column "B" to define how far down the counter should go.
This is what I have so far
Sub Counter()
Dim NoF As Long
Dim Test As Long
NoF = Range("B1", Range("B1").End(xlDown)).Count
For i = 1 To NoF
If Cells(i, 1) = "" Then
ActiveSheet.Cells(i, 1).Value = i
ElseIf Cells(i, 1) <> "" Then
ActiveSheet.Cells(i, 1).Offset(i + 1, 1).Select
End If
Next i
End Sub
You could use a second variable which counts the rows with text. Initialize it outside of the for loop to zero and add 1 if there was some text. Next, you just need to subtract it from i.
j = 0
For i = 1 To NoF
If Cells(i, 1) = "" Then
ActiveSheet.Cells(i, 1).Value = i - j
ElseIf Cells(i, 1) <> "" Then
ActiveSheet.Cells(i, 1).Offset(i + 1, 1).Select
j = j + 1
End If
Next i
You do not need to Offset, this works as well
Option Explicit
Sub Counter()
Dim NoF As Long
Dim j As Long
Dim i As Long
NoF = Range("B1", Range("B1").End(xlDown)).Count
j = 0
For i = 1 To NoF
If Cells(i, 1) = "" Then
Cells(i, 1).Value = i - j
Else
j = j + 1
End If
Next i
End Sub
this is part of my code that i am working with and I have one problem. I have array with values (masyvas) and i started new loop to find other values by using masyvas(i,1) values and after that i need that new values would be printed in masyvas(i,2) and i need to group them. It need to look like this:
991988 Gaz.duon.sk"Giros"gaiv.g.1,5L 5_PETØFLAT1,5
PALINK
117388 Silp.gaz.nat.min.v"Tiche'1,5L 5_PETØFLAT1,5
PALINK
RIMI LIETUVA
ŠIAULIŲ TARA
111388 Gaz.nat.min.v"Tiche" 1,5L pet 5_PETØFLAT1,5
PALINK
AIBĖS LOGISTIKA
AIBĖS LOGISTIKA
RIMI LIETUVA
ŠIAULIŲ TARA
How it looks now from marked 1 it goes wrong
Data sheet where i get array values
Here is part of my code where i have this problem now it prints new values next to masyvas(i,2) but not below as I need.
lastrow2 = Sheets("lapas").Cells(Rows.Count, 1).End(xlUp).Row
rub = lastrow2
cub = 3
ReDim masyvas(1 To rub, 1 To cub)
For i = 1 To rub
For j = 1 To cub
masyvas(i, j) = Sheets("lapas").Cells(i, j).Value 'array gets values from filtered data in AKCIJOS sheet
Next
Next
Sheets("lapas").Range("A1:C100").Clear
For i = 1 To rub Step 1
Set rng2 = grafikas.Cells(6 + h, 2)
prekeskodas = masyvas(i, 1)
For m = 2 To lastrow
If akcijos.Cells(m, 8) >= laikas And akcijos.Cells(m, 8) <= laikas2 Then
If prekeskodas = akcijos.Cells(m, 4) Then
grafikas.Cells(7 + r, 2).EntireRow.Select
Selection.Insert Shift:=xlDown
grafikas.Cells(7 + r, 3) = akcijos.Cells(m, 3)
r = r + 1
h = r
End If
End If
Next m
For j = 1 To cub Step 1
rng2.Offset(i - 1, j - 1).Value = masyvas(i, j)
Next
Next
You didn't provide any screenshot of your data, so it's hard to say what exactly is your problem and desired output, but try the code below. I marked changed lines.
For i = 1 To rub
prekeskodas = masyvas(i, 1)
For m = 2 To lastrow
If akcijos.Cells(m, 8) >= laikas And akcijos.Cells(m, 8) <= laikas2 Then
If prekeskodas = akcijos.Cells(m, 4) Then
'masyvas(i, 2) = masyvas(i, 2) & akcijos.Cells(m, 3)
masyvas(i, m) = masyvas(i, m) & akcijos.Cells(m, 3) '<------
End If
End If
Next
For j = 1 To cub
rng2.Offset(j - 1, i - 1).Value = masyvas(i, j) '<-----
Next
Next
I HAVE UPDATED THIS
Update highlights
Changed part of the code to remove unnecessary commas in the resultant Sheet8.L5 field.
Also implemented the suggestion suggested by feelththis.
Now it just returns "1,9" instead of the desired "1, 9, 29, 37, 50, 61"
Original (slightly changed post)
I am trying to get cell data from three sheets, five cells per sheet for a total of fifteen cells. Remove all zero values. Numerically order the remaining. The insert it into a single cell on another sheet comma delimited. All cell data should contain only positive, whole numbers.
I have provided a sample of what the data looks like and my code below. If there is a better way of approaching this than the way I am attempting I am open to other solutions.
The code below does return an error in AggregateSeptember() the line that returns the error has a comment explaining it. Thank you feelththis.
After execution Sheet 8 L5 should = "1, 9, 29, 37, 50, 61"
I am totally stumped by this and haven't written any VB before, I would appreciate any help with this.
Thanks in advance for your time and consideration,
Tim
The DATA below is before VBA runs. After the code runs Sheet8.L5.value = "1, 9, 29, 37, 50, 61" as stated above.)
DATA
Sheet 5
M5 N5 O5 P5 Q5 R5
37 0 0 0 0 0
Sheet 6
M5 N5 O5 P5 Q5 R5
1 9 0 0 0 0
Sheet 7
M5 N5 O5 P5 Q5 R5
29 50 61 0 0 0
Sheet 8
L5
0
DATA
Sub AggregateSeptember()
Dim i As Integer
Dim j As Integer
Dim SeptemberTerm1Aggregate As String
Dim SeptemberTerm1(0 To 14) As Integer
Dim SeptemberTerm2() As Integer
Dim SeptemberCols
SeptemberCols = Array("M5", "N5", "O5", "P5", "Q5")
For i = 0 To 14
If i < 5 Then
If Sheet5.Range(SeptemberCols(i)) <> 0 Then
SeptemberTerm1(i) = Sheet5.Range(SeptemberCols(i))
End If
ElseIf i < 10 Then
If Sheet6.Range(SeptemberCols(i - 5)) <> 0 Then
SeptemberTerm1(i - 5) = Sheet6.Range(SeptemberCols(i - 5))
End If
ElseIf i < 15 Then
If Sheet7.Range(SeptemberCols(i - 10)) <> 0 Then
SeptemberTerm1(i - 10) = Sheet7.Range(SeptemberCols(i - 10))
End If
End If
Next i
' This next line no longer returns an error
SeptemberTerm2 = BubbleSrt(SeptemberTerm1, True)
For j = 0 To 14
If SeptemberTerm2(j) > 0 Then SeptemberTerm1Aggregate = SeptemberTerm1Aggregate & SeptemberTerm2(j)
If j > 0 And j < 14 And SeptemberTerm2(j) > 0 Then SeptemberTerm1Aggregate = SeptemberTerm1Aggregate & ", "
Next j
Sheet8.Range("L5").Value = SeptemberTerm1Aggregate
End Sub
Public Function BubbleSrt(ArrayIn, Ascending As Boolean)
Dim SrtTemp As Variant
Dim i As Long
Dim j As Long
If Ascending = True Then
For i = LBound(ArrayIn) To UBound(ArrayIn)
For j = i + 1 To UBound(ArrayIn)
If ArrayIn(i) > ArrayIn(j) Then
SrtTemp = ArrayIn(j)
ArrayIn(j) = ArrayIn(i)
ArrayIn(i) = SrtTemp
End If
Next j
Next i
Else
For i = LBound(ArrayIn) To UBound(ArrayIn)
For j = i + 1 To UBound(ArrayIn)
If ArrayIn(i) < ArrayIn(j) Then
SrtTemp = ArrayIn(j)
ArrayIn(j) = ArrayIn(i)
ArrayIn(i) = SrtTemp
End If
Next j
Next i
End If
BubbleSrt = ArrayIn
End Function
Well, it seems you were faster than me, but here's my solution anway. Just change "Sheet1", ..., "Sheet4" to whatever you need.
Sub AggregateSeptember()
Dim i As Integer ' Counter for Sheets
Dim j As Integer ' Counter for Columns
Dim k As Integer ' Counter for your data
Dim vMySheets As Variant ' Sheets
Dim vSeptemberCols As Variant ' Columns
Dim iCurrent As Integer ' Current data
Dim iSeptemberTerm() As Integer ' Data array
Dim sAggregate As String ' Aggregate string
vMySheets = Array("Sheet1", "Sheet2", "Sheet3")
vSeptemberCols = Array("M5", "N5", "O5", "P5", "Q5", "R5")
ReDim iSeptemberTerm(0 To (UBound(vMySheets) + 1) * (UBound(vSeptemberCols) + 1) - 1)
k = 0
For i = LBound(vMySheets) To UBound(vMySheets)
For j = LBound(vSeptemberCols) To UBound(vSeptemberCols)
iCurrent = ThisWorkbook.Sheets(vMySheets(i)).Range(vSeptemberCols(j)).Value
If iCurrent <> 0 Then
iSeptemberTerm(k) = iCurrent
k = k + 1
End If
Next j
Next i
ReDim Preserve iSeptemberTerm(0 To k - 1) ' This is just to eliminate the unused elements
iSeptemberTerm = BubbleSrt(iSeptemberTerm, True)
For i = LBound(iSeptemberTerm) To UBound(iSeptemberTerm)
sAggregate = sAggregate & iSeptemberTerm(i) & ", "
Next i
sAggregate = Left(sAggregate, Len(sAggregate) - Len(", "))
ThisWorkbook.Sheets("Sheet4").Range("L5").Value = sAggregate
End Sub
A few notes:
Don't be afraid to throw in new counters, if needed :)
You forgot to put "R5" in SeptemberCols
You can reuse the same counter in other loops (you could use i in your second For)
Note that I was able to make iSeptemberTerm = BubbleSrt(iSeptemberTerm, True) because of how I declared it (without fixed bounds, so that I can dinamically change it)
I have solved it. Although if anyone has any thoughts on a way to do this looping through multiple rows or a more efficient way to accomplish this that would be great.
I have posted the correct code below. I left the two offending lines in but commented out if anyone wants to look. Stupid mistake on my part.
Thank you to anyone who spent any amount of time on this, specifically feelththis.
Sub AggregateSeptember()
Dim i As Integer
Dim j As Integer
Dim SeptemberTerm1Aggregate As String
Dim SeptemberTerm1(0 To 14) As Integer
Dim SeptemberTerm2() As Integer
Dim SeptemberCols
SeptemberCols = Array("M5", "N5", "O5", "P5", "Q5")
For i = 0 To 14
If i < 5 Then
If Sheet5.Range(SeptemberCols(i)) <> 0 Then
SeptemberTerm1(i) = Sheet5.Range(SeptemberCols(i))
End If
ElseIf i < 10 Then
If Sheet6.Range(SeptemberCols(i - 5)) <> 0 Then
'SeptemberTerm1(i - 5) = Sheet6.Range(SeptemberCols(i - 5))
SeptemberTerm1(i) = Sheet6.Range(SeptemberCols(i - 5))
End If
ElseIf i < 15 Then
If Sheet7.Range(SeptemberCols(i - 10)) <> 0 Then
'SeptemberTerm1(i - 10) = Sheet7.Range(SeptemberCols(i - 10))
SeptemberTerm1(i) = Sheet7.Range(SeptemberCols(i - 10))
End If
End If
Next i
' This next line no longer returns an error
SeptemberTerm2 = BubbleSrt(SeptemberTerm1, True)
For j = 0 To 14
If SeptemberTerm2(j) > 0 Then SeptemberTerm1Aggregate = SeptemberTerm1Aggregate & SeptemberTerm2(j)
If j > 0 And j < 14 And SeptemberTerm2(j) > 0 Then SeptemberTerm1Aggregate = SeptemberTerm1Aggregate & ", "
Next j
Sheet8.Range("L5").Value = SeptemberTerm1Aggregate
End Sub
Public Function BubbleSrt(ArrayIn, Ascending As Boolean)
Dim SrtTemp As Variant
Dim i As Long
Dim j As Long
If Ascending = True Then
For i = LBound(ArrayIn) To UBound(ArrayIn)
For j = i + 1 To UBound(ArrayIn)
If ArrayIn(i) > ArrayIn(j) Then
SrtTemp = ArrayIn(j)
ArrayIn(j) = ArrayIn(i)
ArrayIn(i) = SrtTemp
End If
Next j
Next i
Else
For i = LBound(ArrayIn) To UBound(ArrayIn)
For j = i + 1 To UBound(ArrayIn)
If ArrayIn(i) < ArrayIn(j) Then
SrtTemp = ArrayIn(j)
ArrayIn(j) = ArrayIn(i)
ArrayIn(i) = SrtTemp
End If
Next j
Next i
End If
BubbleSrt = ArrayIn
End Function