I am trying to calculate a 6 month running sum of "Points" for each badge number. The sum only applies to fields with points greater than 0.
I have been trying to do this using an array and a For statement, but I'm not getting anywhere.
Sub TestArray()
'
'
'
' Test Array Macro
Dim Badges() As Long
Dim Badge As Variant
Dim i As Long
Dim x As Double
Dim Worksheet1 As Worksheet
Dim AbsCode As Long
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ActiveSheet
'Using Find Function
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set Worksheet1 = ActiveWorkbook.Worksheets("Attendance Data") ' Change name of sheet if necessary
BadgeNo = 1
AbsCode = 3
Hours = 5
Points = 9
Rules = 10
test = 15
ReDim Badges(2 To LastRow, 1 To 1)
For Each Badge In Badges
For i = 2 To LastRow
If Worksheet1.Cells(i, Points).Value > 0 Then
Worksheet1.Cells(i, test).Value = Application.WorksheetFunction.Sum(Worksheet1.Cells(i, Points).Value)
Else: Worksheet1.Cells(i, test).Value = 0
End If
Next i
Next Name
End Sub
The answer that I'm looking for is in the "6 Month Points" column below.
Badge No. Incident Date Points 6 Month Points
30004832 1/13/2018 0.5 0.5
30004832 1/27/2018 0.0 0
30004832 4/5/2018 1.0 1.5
30004832 7/19/2018 0.0 0
30004832 7/22/2018 0.5 1.5
30004832 9/22/2018 1.0 2.5
30005505 8/4/2018 0.5 0.5
30005505 12/6/2018 0.5 1
30005914 12/20/2018 0.0 0
30004641 1/18/2018 0.5 0.5
30004641 2/2/2018 0.5 1
30004641 7/17/2018 0.0 0
30004641 10/16/2018 0.0 0
30000503 4/12/2012 0.0 0
30000503 5/3/2012 0.0 0
30000503 6/14/2012 0.0 0
Related
I'm trying to assign a 1-dimensional array's values to cell range.
For example; my array has 23 items (every item randomized from 1 to 5) and my cell range is range A1 to I7.
I want to assign every value of my array to this cell range randomly.
I randomize the cell values with my array but my array's values are not completely assigned to cells.
Sub define_ore_body()
Dim lb_grade As Integer, ub_grade As Integer
Dim ore_body(1 To 23) As Variant
Dim i As Integer, j As Integer, k As Integer
Dim a As Object
Dim b As Range
Application.ScreenUpdating = False
'my selected range area A1toI7
Set b = Application.Range("A1:I7")
Set a = Application.Cells
'******* low and high ore bound ******
lb_grade = InputBox("Enter lowest ore grade:")
ub_grade = InputBox("Enter highest ore grade:")
'The reason why I do it as follows is that if the random lower bound does not start from 1,
'the largest random number it generates is 2 more than the value I have entered, so
If lb_grade > 1 Then
ub_grade = ub_grade - 2
End If
'******* Random Array ******
'array has 23 items
For i = 1 To 23
ore_body(i) = Int((ub_grade * Rnd) + lb_grade)
Next i
'******* filling random cells with my array******
k = 1
For Each a In b
If a.Value = "" And k < 23 Then
b(Int(7 * Rnd + 1), (8 * Rnd + 1)) = ore_body(k)
ElseIf a.Count > 23 And k > 23 Then
Exit For
Else
k = k + 1
End If
Next a
'******* after filling cell now fill empty cells with Zero******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) = "" Then
Cells(i, j) = 0
Else
End If
Next j
Next i
'******* Coloring only containing array values******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) > 0 Then
Application.Cells(i, j).Interior.ColorIndex = 38
Else
End If
Next j
Next i
End Sub
The array contains 23 items that initialize to Variant/Empty:
Dim ore_body(1 To 23) As Variant
Make that 63 items that initialize to 0:
Dim ore_body(1 To 63) As Long
The rest of the code will now populate the first 23 elements, because that's what the loop does:
For i = 1 To 23
If you want the loop to run through all indexes, consider using LBound and UBound operators to programmatically retrieve the lower and upper boundaries of the array, respectively:
For i = LBound(ore_body) To UBound(ore_body)
Note that you have 23 hard-coded in several places, which is going to make it harder than necessary to modify if/when that 23 needs to be come a 25. Consider replacing every occurrence of it by a Const:
Const ElementCount As Long = 23
Then every instance of 23 can become ElementCount, and then when it needs to become 25 then there's only one place that needs any code to change.
Loop through the array.
Set a to a random cell in the range A1:I7.
If cell is empty put the value from the array in the cell, if it
isn't repeat step 2
Sub define_ore_body()
Dim lb_grade As Integer, ub_grade As Integer
Dim ore_body(1 To 23) As Variant
Dim i As Long, j As Long, k As Long
Dim a As Range
Dim b As Range
Application.ScreenUpdating = False
'my selected range area A1:I7
Set b = Application.Range("A1:I7")
' clear A1:A17
b.Clear
'******* low and high ore bound ******
lb_grade = InputBox("Enter lowest ore grade:")
ub_grade = InputBox("Enter highest ore grade:")
'The reason why I do it as follows is that if the random lower bound does not start from 1,
'the largest random number it generates is 2 more than the value I have entered, so
If lb_grade > 1 Then
ub_grade = ub_grade - 2
End If
'******* Random Array ******
'array has 23 items
For i = 1 To 23
ore_body(i) = Int((ub_grade * Rnd) + lb_grade)
Next i
'******* filling random cells with my array******
For k = 1 To 23
Do
Set a = b.Cells(Int(7 * Rnd) + 1, Int(9 * Rnd) + 1)
Loop Until a.Value = ""
a.Value = ore_body(k)
Next k
'******* after filling cell now fill empty cells with Zero******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) = "" Then
Cells(i, j) = 0
Else
End If
Next j
Next i
'******* Coloring only containing array values******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) > 0 Then
Application.Cells(i, j).Interior.ColorIndex = 38
Else
End If
Next j
Next i
End Sub
I have some data, stored in arrays like
Dim arrA, arrB, arrC, arrAi, arrBi
Dim i as integer, x as integer
for i = 1 to 100
if cells(i,1).value = "criteria" then ' just add value to array when it meets some criteria
x = x + 1
arrA(x) = cells(i,1).value
arrB(x) = cells(i,2).value
arrC(x) = cells(i,3).value
end if
next i
redim preserve arrA(1 to x)
redim preserve arrB(1 to x)
redim preserve arrC(1 to x)
And the data looks like
arrA: 26.1 40.2 80.3 26.0 41.3 78.7 25.8 40.8 80.0
arrB: 10 11 10 66 67 64 32 32 33
arrC: 1 2 3 1 2 3 1 2 3
Since the values in arrA 26.1, 26.0, 25.8 (position 1, 4, 7) belong to group 1 (referencing to values in arrC at same position), I would like to store 26.1 26.0 25.8 to arrAi and 10 66 32 to arrBi for subsequent calculations.
How can I loop through the 3 arrays and store values to another array as described above?
Thanks in advance.
Try the next way, please:
Sub handleArraysFromArrays()
'your existing code...
'but you fistly must declare
Dim arrA(1 To 100), arrB(1 To 100), arrC(1 To 100)
'....
'your existing code
'...
Dim k As Long, kk As Long
ReDim arrAi(1 To UBound(arrA))
ReDim arrBi(1 To UBound(arrA))
For i = 1 To UBound(arrC)
If arrC(i, 1) = 1 Then k = k + 1: arrAi(k, 1) = arrA(i, 1)
If arrC(i, 1) = 2 Then kk = kk + 1: arrBi(kk, 1) = arrA(i, 1)
Next i
ReDim Preserve arrAi(1 To k): ReDim Preserve arrBi(1 To kk)
Debug.Print UBound(arrAi), UBound(arrBi)
End Sub
I hope you guys can help me. I have an Excel sheet with data that I want to copy some some values and move them to another column.
The data currently is something like this:
A B
...
20:00:00 2456
21:00:00 2147
22:00:00 5623
23:00:00 1247
00:00:00 3549
01:00:00 1234
...
I have data from several days, and when I found the string "00:00:00" which is the beginning of another day, I want to copy the prior 24 values to the next column.
The result should be something like this:
A B C D
...
20:00:00 2456
21:00:00 2147
22:00:00 5623
23:00:00 1247
00:00:00 3549
01:00:00 1234
...
22:00:00 2418
23:00:00 3245
00:00:00 3549
01:00:00 5437
I've started to try found the row number of the values equal to "00:00:00", save them in an array and then make the difference between row value(i+1) "00:00:00" and row value(i) "00:00:00"
Thanks and regards,
Daniel Duarte
this has been tested just now:
Sub move()
Dim column As Integer
column = 3
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i + 1, 1).Value > Cells(i, 1).Value and Cells(i + 1, 1).Value <> "" Then
Cells(i, column).Value = Cells(i, 2).Value
Cells(i, 2).Value = ""
Else
column = column + 1
Cells(i, column).Value = Cells(i, 2).Value
Cells(i, 2).Value = ""
End If
Next
End Sub
one caveat in this is the case that it is checking if the next hour is less than current, i.e. hour goes back to zero at midnight and it increases the column where it pastes too. It will work for any times within 24 hours window, irrelevant from minutes/seconds
You made a mention of the '24', so I thought it was 24 elements consistently. Is the timing consistent, or variable?
The solution in VBA is below.
Given something like this:
time value
20:00 100
21:00 200
22:00 300
23:00 400
0:00 500
1:00 600
2:00 700
3:00 800
4:00 900
5:00 1000
6:00 1100
7:00 1200
8:00 1300
9:00 1400
10:00 1500
11:00 1600
12:00 1700
13:00 1800
14:00 1900
15:00 2000
16:00 2100
17:00 2200
18:00 2300
19:00 2400
20:00 2500
21:00 2600
22:00 2700
23:00 2800
0:00 2900
1:00 3000
2:00 3100
3:00 3200
4:00 3300
5:00 3400
6:00 3500
7:00 3600
8:00 3700
9:00 3800
10:00 3900
11:00 4000
12:00 4100
13:00 4200
14:00 4300
15:00 4400
16:00 4500
17:00 4600
18:00 4700
19:00 4800
20:00 4900
21:00 5000
22:00 5100
23:00 5200
Is this what you are looking for?
Option Explicit
Sub shift()
Dim Test As String
Dim NumRows As Integer
Dim CurrentRow As Integer
Dim ToCopy As String
Dim x As Integer
Dim i As Integer
' Set numrows = number of rows of data.
NumRows = Range("A2", Range("A2").End(xlDown)).Rows.Count
' loop around
For x = 0 To NumRows - 1
Range("A2").Offset(x, 0).Select
Test = ActiveCell.Text
If Val(Test) = 0 Then
CurrentRow = ActiveCell.Row
If ((CurrentRow - 24) > 1) Then
For i = 1 To 24
If ((CurrentRow - i - 24) > 0) Then
ToCopy = ActiveCell.Offset(-i - 24 + 1, 1).Text
ActiveCell.Offset(-i + 1, 2).Value = ToCopy
End If
Next i
End If
Else
End If
Next
End Sub
Modifying this for the arbitrary case; for example, with time differences of 0:15.
This is a bit wordy/pendantic, but gives you the idea.
Option Explicit
Sub shift_arb()
Dim Test As String
Dim StartRow As Integer
Dim EndRow As Integer
Dim NumRows As Integer
Dim nZeroRows As Integer
Dim CurrentRow As Integer
Dim ToCopy As String
Dim x As Integer
Dim i As Integer
' Set numrows = number of rows of data.
NumRows = Range("A2", Range("A2").End(xlDown)).Rows.Count
' Establish "For" loop to loop "numrows" number of times.
For x = 0 To NumRows - 1
Range("A2").Offset(x, 0).Select
Test = ActiveCell.Text
' If we meet the critera; store the row values of the zero rows
If TimeValue(Test) = "12:00:00 AM" Then
nZeroRows = nZeroRows + 1
StartRow = EndRow
EndRow = ActiveCell.Row
' Only do this if you've hit the second zero row
' After this, we have to backfill the first, since we don't know the
' gap between the zeros
If (nZeroRows > 1) Then
' Go from one zero row to the next
For i = 0 To (EndRow - StartRow)
If ((StartRow - i) > 1) Then
ToCopy = Cells(StartRow - i, 2).Text
Cells(EndRow - i, 3).Value = ToCopy
End If
Next i
End If
End If
Next x
' At the end, cleanup, and do the rest.
Debug.Print StartRow, EndRow, ActiveCell.Row
For i = 0 To (EndRow - StartRow)
If ((i + EndRow - 1) < ActiveCell.Row) Then
ToCopy = Cells(StartRow + i, 2).Text
Cells(EndRow + i, 3).Value = ToCopy
End If
Next i
End Sub
There are two FOR EACH loops in the code below. The first FOR loop cycles through the first array (shape 1,shape 2 ,shape 3).The second FOR loop cycles through the second array (0.3, 0.4, 0.5).
Shape 1 0.3
Shape 2 0.4
Shape 3 0.5
The second FOR loop colors the shape on my worksheet based on the value of second array. The problem is all of my shapes are being colored with first value (i.e 0.3). I want Shape 1 to be colored based on 0.3 , Shape 2 based on 0.4 and so on. Thanks for helping me with this.
Private Sub Worksheet_Calculate()
Dim arr1
Dim arr2
Set arr1 = Worksheets("Sheet2").Range("valueforarr1")
Set arr2 = Worksheets("Sheet2").Range("Valueforarr2")
Dim c, d As Range
For Each c In arr1
c = Replace(c, " ", "_")
MsgBox c
For Each d In arr2
If d >= 0.2 And d <= 0.3 Then
Worksheets("Sheet1").Shapes(c).Fill.ForeColor.RGB = RGB(237, 247, 249)
Exit For
ElseIf d > 0.3 And d <= 0.4 Then
Worksheets("Sheet1").Shapes(c).Fill.ForeColor.RGB = RGB(218, 238, 243)
Exit For
ElseIf d > 0.4 And d <= 0.5 Then
Worksheets("Sheet1").Shapes(c).Fill.ForeColor.RGB = RGB(183, 222, 232)
Exit For
ElseIf d > 0.5 Then
Worksheets("Sheet1").Shapes(c).Fill.ForeColor.RGB = RGB(146, 205, 220)
Exit For
ElseIf d Is Nothing Then
Worksheets("Sheet1").Shapes(c).Fill.ForeColor.RGB = RGB(255, 255, 255)
Exit For
End If
Next d
Next c
End Sub
Hmm.. i guess your Problem is the second loop.
You take the First Shape and match it with all Values of the second Range-loop
What your loops are doing is:
Shape 1 -> 0.3
Shape 1 -> 0.4
Shape 1 -> 0.5
than the same with Shape 2
Shape 2 -> 0.3
Shape 2 -> 0.4 etc.
So if im Right its always the last Value of Range2
Dim intRow As Integer
intRow = 1
For Each c In arr1
c = Replace(c, " ", "_")
MsgBox c
If Worksheets("Sheet1").Cells(intRow,2).value = "0.3" Then
Worksheets("Sheet1").Shapes(c).Fill.ForeColor.RGB = RGB(237, 247, 249)
Exit For
If Worksheets("Sheet1").Cells(intRow,2).value = "0.4" Then
Worksheets("Sheet1").Shapes(c).Fill.ForeColor.RGB = RGB(237, 247, 249)
Exit For
If Worksheets("Sheet1").Cells(intRow,2).value = "0.5" Then
Worksheets("Sheet1").Shapes(c).Fill.ForeColor.RGB = RGB(237, 247, 249)
Exit For
intRow=intRow+1
Next c
I think this will do what you need. You will need to change the Set myShapes = ... and Set myValues = ... lines to point to your ranges.
Sub Worksheet_Calculate()
Dim myShapes As Range
Set myShapes = Worksheets("Sheet1").Range("A1:A5")
Dim myValues As Range
Set myValues = Worksheets("Sheet1").Range("B1:B5")
For i = 1 To myShapes.Rows.Count
Select Case myValues.Rows(i)
Case Is = 0.3
Worksheets("Sheet1").shapes(myShapes(i)).Fill.ForeColor.RGB = RGB(237, 247, 249)
Case Is = 0.4
Worksheets("Sheet1").shapes(myShapes(i)).Fill.ForeColor.RGB = RGB(218, 238, 243)
Case Is = 0.5
Worksheets("Sheet1").shapes(myShapes(i)).Fill.ForeColor.RGB = RGB(183, 222, 232)
Case Is > 0.5
Worksheets("Sheet1").shapes(myShapes(i)).Fill.ForeColor.RGB = RGB(146, 205, 220)
Case Else
Worksheets("Sheet1").shapes(myShapes(i)).Fill.ForeColor.RGB = RGB(255, 255, 255)
End Select
Next i
End Sub
One note:
What you are calling arrays (arr1, arr2) are actually Range objects.
EDIT: Updated question using some of the suggestions below. This produces weird output though.
Dim ProviderArray() As Variant
Sub GetProviderNumbers()
Dim InputRange As Range
Dim WorkRange As Range
Set InputRange = Range("ProviderList")
Set WorkRange = Application.Intersect(InputRange, ActiveSheet.UsedRange)
SizeOfArray = Application.WorksheetFunction.CountA(WorkRange)
ReDim ProviderArray(0 To SizeOfArray)
ProviderArray = WorkRange.Value
For r = 1 To UBound(ProviderArray, 1)
For C = 1 To UBound(ProviderArray, 2)
Debug.Print r, C, ProviderArray(r, C)
Next C
Next r
End Sub
1 1 5555
2 1 4444654
3 1 654654
4 1 654654654
5 1
6 1
7 1
8 1
9 1
10 1
11 1
12 1
13 1
14 1
15 1
16 1
17 1
18 1
19 1
Could someone explain why this output?
You can only use the one-line approach if you put the range into a 2-D array: you only have a 1-D array.
You could do this:
Dim ProviderArray()
Set WorkRange = .Intersect(InputRange, ActiveSheet.UsedRange)
'This makes ProviderArray a 2-D array, dimension 1 = # rows,
' dimension2 = #cols. Both dimensions are 1-based.
ProviderArray = WorkRange.value
for r=1 to ubound(ProviderArray,1)
for c=1 to ubound(ProviderArray,2)
debug.print r,c,ProviderArray(r,c)
next c
next r
Maybe something a bit simpler like:
Private Sub GetProviderNumbers()
Dim InputRange() As Variant
InputRange = Range("ProviderList")
For Each i In InputRange
Debug.Print i
Next
End Sub
This captures a two-dimensional range and stores the values in a global two-dimensional array:
Dim ProviderArray() As String
Sub MAIN()
Range("B2:C11").Name = "ProviderList"
Call GetProviderNumbers
End Sub
Sub GetProviderNumbers()
ary = Range("Providerlist")
ll = LBound(ary, 1)
lm = LBound(ary, 2)
ul = UBound(ary, 1)
um = UBound(ary, 2)
ReDim ProviderArray(ll To ul, lm To um)
For i = ll To ul
For j = lm To um
ProviderArray(i, j) = ary(i, j)
Next
Next
End Sub