So we have this activity to average values based on an hourly basis using excel vba.
Basically, what we are tasked to do is to average the values of cells separately.
An average for 9 PM to 10 PM, 10 PM to 11 etc. I've looked to many different methods and I still can't figure it out how to do that.
I know this can be easily done using a pivottable or using averageif but we are tasked to do this in excel vba.
This is my current code:
Sub test()
Dim a As Collection
Dim lastrow As Integer
Set a = New Collection
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
If Sheet1.Range("A1").Value > TimeValue("09:00:00") Then
For x = 1 To lastrow
y = Cells(x, 2).Value
a.Add (y)
Next x
For Z = 1 To a.Count
f = a.Item(Z) + f
Next Z
Range("C1").Value = (f / a.Count)
ElseIf Sheet1.Range("A1").Value < TimeValue("09:00:00") Then
For x = 1 To lastrow
y = Cells(x, 2).Value
a.Add (y)
Next x
For Z = 1 To a.Count
f = a.Item(Z) + f
Next Z
Range("C2").Value = (f / a.Count)
End If
End Sub
This is how my data looks like:
Related
the first 23 columns of the array called arr are 40 rows full of integer data ranging from 1-10. if the data is of value 2 then we keep count of how many there are. they are considered yellow values. the second array is called sheetArr and it's values are strings representing the month's of the year. If the string ends with "03" then that represents the month of March so we set a variable x to be of value 3. We want to plot the amount of yellow values there are in every month, yellow values being on the y-axis and the months being on the x-axis. The count of the yellow values are in the 24th column of the array. and each row in that array is associated to a row in the sheetArr at the same location. So arr(24, 0) is associated with sheetArr(0, 0). Lets say there were 5 yellow values in arr(24, 0) and the month associated to sheetArr(0,0) is 1 (Representing January). The graph would plot the value 5 on the y-axis and the value 1 on the x-axis. I also want the graph to be a plotted graph. Like dots on the graph and then have the dots connect with lines. When I run my code I get nothing plotted on my graph. Someone please help, Thanks.
Sub createGraph()
Dim i As Integer
Dim j As Integer
Dim y As Integer
Dim x As Integer
Dim z As String
Dim sheetCount As Integer
Dim pptText As String
Dim count As Integer
Dim countYellow As Integer
Dim arr(25, 40)
Dim sheetArr(0, 23)
For i = 0 To 23 'iterating through all columns of the array to count the yellows
countYellow = 0
For j = 0 To 40 'iterating through 40 rows
If arr(i, j) = 2 Then 'if its yellow
countYellow = countYellow + 1
End If
Next
arr(24, i) = countYellow
Next
'Plotting the graph and then changing features in the graph
i = 0
Charts.Add
ActiveChart.ChartType = xlXYScatterLinesNoMarkers
With ActiveChart.SeriesCollection
For i = 0 To count - 1
y = arr(24, i) 'The yellow count value
z = sheetArr(0, i) 'The name of the sheet
z = Right(z, 2)
If z = "01" Then 'if the name of the sheet ends with 01 then its january
x = 1 '1 representing January
ElseIf z = "02" Then
x = 2
ElseIf z = "03" Then
x = 3
ElseIf z = "04" Then
x = 4
ElseIf z = "05" Then
x = 5
ElseIf z = "06" Then
x = 6
ElseIf z = "07" Then
x = 7
ElseIf z = "08" Then
x = 8
ElseIf z = "09" Then
x = 9
ElseIf z = "10" Then
x = 10
ElseIf z = "11" Then
x = 11
ElseIf z = "12" Then
x = 12
End If
.Item(1).Values = y 'plot the yellow count
.Item(1).XValues = x 'plot the name of the sheet
Next
ActiveChart.SetElement msoElementPrimaryCategoryAxisShow
ActiveChart.SetElement msoElementPrimaryCategoryAxisTitleHorizontal
ActiveChart.SetElement msoElementPrimaryValueAxisShow
ActiveChart.SetElement msoElementPrimaryValueAxisTitleHorizontal
ActiveChart.ChartArea.Format.Fill.ForeColor.RGB = RGB(253, 242, 227)
End With
ActiveChart.ChartArea.Select
End Sub
This code copies the entire row to another when the word 'ordered' is in a certain column.
However, I need to adapt this code to not copy the entire row for another function but requires only copying columns A:J over into the next sheet but I'm having difficulty achieving this.
Sub MovingOrderedItems()
Dim xRg As Range
Dim xCell As Range
Dim X As Long
Dim Y As Long
Dim Z As Long
X = Worksheets("Engineer-Items to be ordered").UsedRange.Rows.Count
Y = Worksheets("Admin").UsedRange.Rows.Count
If Y = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Admin").UsedRange) = 0 Then Y = 0
End If
Set xRg = Worksheets("Engineer-Items to be ordered").Range("N3:N" & X)
On Error Resume Next
Application.ScreenUpdating = False
For Z = 1 To xRg.Count
If CStr(xRg(Z).Value) = "ordered" Then
xRg(Z).EntireRow.Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
xRg(Z).EntireRow.Delete
If CStr(xRg(Z).Value) = "ordered" Then
Z = Z - 1
End If
Y = Y + 1
End If
Next
Application.ScreenUpdating = True
End Sub
There's probably a more elegant way to do this, but you can replace
xRg(Z).EntireRow.Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
With
Range(xRg(Z).EntireRow.Cells(1, 1), xRg(Z).EntireRow.Cells(1, 10)).Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
I have the values on the range "A1:O1".
Each Column has a unique value in this range.
I need help to develop a loop that will fill down 04 times on each column the same Top Value (Column Value). Below a Pseudo Code
Sub FillDownRowsRandomly()
Dim i As Integer, j As Integer
'RamdomRow=Total of 04 unique ramdom numbers
'choosen from 01 to 06 {1,2,3,4,5,6}
'meaning that in a loop of 6 interations, when fill down
'2 will be Null or empty
'
For i = 1 To 15 'Columns "A" To "O"
For j = 2 To 7 '
'
Cells(RandomRow, i).Value = Cells(1, i).Value
Next j
Next i
End Sub
Below an Image where will be possible identify the result of the code.
Disregard the "Null" word written in the cells. I wrote that just to clarify that during the random loop, the code "ignored that cell".
Maybe something like:
Sub FillDownRowsRandomly()
Dim x As Long, y As Long, z As Long
With Sheet1 'Change accordingly
For y = 1 To 15
z = 0
Do While z < 4
x = Int((7 - 2 + 1) * Rnd + 2)
If .Cells(x, y) <> .Cells(1, y) Then
.Cells(x, y) = .Cells(1, y)
z = z + 1
End If
Loop
Next y
End With
End Sub
Loop the columns and randomly place the values till there are four in the six rows.
Sub FillDownRowsRandomly()
ActiveSheet.Range("A2:O7").ClearContents
Dim i As Long
For i = 1 To 15 'iterate the columns
Do Until Application.CountIf(ActiveSheet.Cells(2, i).Resize(6), ActiveSheet.Cells(1, i).Value) >= 4
Dim j As Long
j = Application.RandBetween(2, 7)
ActiveSheet.Cells(j, i).Value = ActiveSheet.Cells(1, i).Value
Loop
Next i
End Sub
I am trying to make an Excel transformation using one single formula.
Following image shows the kind of transformation I'm looking for.
If not with formula, is there any other way to do this?
This code will transform your data to Column D as long as data set has a same pattern as I see in your picture.
If data set pattern isn't always the same, then please specify what you need.
Sub Transformation()
Dim LastRowIndex As Integer
Dim Value As Long
y = 1
With ActiveSheet
LastRowIndex = Cells(Rows.Count, "A").End(xlUp).row
End With
For i = 1 To LastRowIndex
Value = Range("B" & i)
For Z = 1 To 4
If Range("C" & y) <> "" Then
Range("D" & y) = Value / 4
y = y + 1
End If
Next Z
Next i
End Sub
i'm currently trying to compare each and every cell in a column with each other in order to find duplicates. I wrote below code, i know it as possible via default Excel functions, but i would like to write a macro with the above mentioned function. Excel currently doesn't respond when i run my code, my guess is that i run a double for loop with 14K cells to compare is each resulting in 14.000*14.000 loops, which is kinda unhandy. Any help will be appreciated :).
Sub findidentical()
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim ColumnG As Integer
x = 0
ColumnG = Application.WorksheetFunction.CountA(Range("G:G"))
'ColumnG is 14K cells long'
For i = 2 To ColumnG
For j = 1 + 1 To ColumnG
If Cells(i, 7).Value = Cells(j, 7).Value Then
x = x + 1 & Cells(i, 7).Font.Bold = True & Cells(j, 7).Font.Bold = True
End If
Next j
Next i
Range("L25").Text = "Amount of duplicates"
Range("L26").Value = x
End Sub
Try this:
Sub findidentical()
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim ColumnG As Integer
x = 0
ColumnG = Application.WorksheetFunction.CountA(Range("G:G"))
'ColumnG is 14K cells long'
For i = 2 To ColumnG
For j = i + 1 To ColumnG
If Cells(i, 7).Value = Cells(j, 7).Value Then
x = x + 1
Cells(i, 7).Font.Bold = True
Cells(j, 7).Font.Bold = True
End If
Next j
Next i
Range("L25").Text = "Amount of duplicates"
Range("L26").Value = x
End Sub
First you need to make each command in the if statement its own line or separate them with : instead of &. & is a string concatenation not a command separator.
Second there is no reason to start Loop j at 2 it has already been compared to everything above. So start it at i+1