Review my simple VBA script with built-in Excel function - vba

Suppose that I have Excel file consists of four worksheets, lets name them as 1, 2, 3 and 4. I want to evaluate a sum of all values from the cells AK10, AK25, AK40 and so on till AK160 on the worksheet 4 and then place it in the cell G23 of worksheet 2.
Here is my macro that I assign to worksheet 2:
Sub sum_up()
Dim i As Integer, s As Integer
s = 0
For i = 0 To 10
s = WorksheetFunction.Sum(s, Worksheets("4").Range("AK(10 + 15 * i)"))
Next i
Range("G23").Value = "s"
End Sub
It ends up with 400 error. What am I doing wrong?

Sub sum_up()
Dim i As Long, s As Long
s = 0
For i = 0 To 10
s = s + Worksheets("4").Cells(10 + 15 * i, "AK").Value
Next i
Range("G23").Value = s
End Sub

I'll take a crack at this - I'd really use a lot more named ranged to pass data back and forth...:
Sub sum_up()
Dim i As Integer, s As Integer
s = 0
For i = 0 To 10
s = s + Worksheets("4").Range("AK" & (10 + 15 * i))
Next I
Range("G23").Value = s
End Sub

you did not say that the summation was to be done using VBA
put this in G23 on worksheet2 (actually, put this in any cell)
=SUM('4'!AK10,'4'!AK25,'4'!AK40,'4'!AK55,'4'!AK70,'4'!AK85,'4'!AK100,'4'!AK115,'4'!AK130,'4'!AK145,'4'!AK160)
as far as what you are doing wrong with your code, that has partly been answered by #KenWhite
you are also putting the letter "s" into G23 of any worksheet that happens to be visible at the time your code runs
put in a reference to sheet 2, same as you referenced sheet 4 just two lines above
this code should work:
Sub sum_up()
Dim ws4 As Worksheet
Set ws4 = ActiveWorkbook.Sheets("4")
Dim rng As Range
Set rng = ws4.Range("ak10") ' point to "ak10"
Dim total As Long
total = rng.Value
Do While True
rng.Select
Set rng = rng.Offset(15) ' move pointer down 15 rows
If rng.Row > 160 Then Exit Do ' moved past row 160 ?
total = total + rng.Value
Loop
ActiveWorkbook.Sheets("2").Range("G23").Value = total
End Sub

Related

Looping CountColour

Some simple code below. I think I'm having trouble with referencing and looping within a loop.
I'd like to count the number of green cells in a row,then move to the next row. I'm getting an error here:
If RowRange.DisplayFormat.Interior.colour = SourceColour.DisplayFormat.Interior.colour Then
Run-time error 91 - object not set....
Any ideas?
Full code:
Sub countcolourloop1()
Dim rng As Range
Dim RowRange As Range
Dim SourceColour As Range
Dim xBackColour As Integer
'count green cells
Set SourceColour = ActiveWorkbook.ActiveSheet.Range("BN2:BN2")
'cyle through each row, add 1 to the counter xBackColour every time you find a cell in the range matching the SourceColour
For I = 4 To 300
Set RowRange = ActiveWorkbook.ActiveSheet.Range("B" & I & ":BK" & I)
If RowRange.DisplayFormat.Interior.colour = SourceColour.DisplayFormat.Interior.colour Then
xBackColour = xBackColour + 1
End If
Next
End Sub

Excel VBA - Conditional highlighting based on many criteria

I have a vba-created speadsheet with 4 sets of criteria. I need to highlight names at the bottom of the sheet based on whether or not they meet all the criteria.
I need the name to highlight if the analyst took 91 minutes or less of total break (B3:F9) each day, 15 minutes or less of tea break (B12:F18), and made at least 3 outbound calls each day (provided the staff time was 8 hours and 58 minutes or more (if it wasn't, the 3 call threshold does not apply)).
So, a function would be something like:
If
TtlB<91 mins & TeaB<15
& If
StfT <8:58:00 ignore ObC
Else If
StfT >8:58:00 & ObC>=3
Highlight (analyst name in A22:A28)
I know it will probably involve a nested loop or two, I just don't know where to get started. The loop for calculating "Total Minutes Owed" is below which can probably be modified to help me get started with this.
Dim i As Integer, j As Integer, k As Integer
j = 3
k = 12
For i = 22 To 28
Range("B" & i) = "=SUM(G" & j & ",G" & k & ")"
j = j + 1
k = k + 1
Next i
I'm pretty shure that a much more compact code can be done. But, since nobody answer you in the last four hours, try the following at least as an start.
Private Sub CommandButton1_Click()
Dim oWs As Worksheet
Dim rAnalysts As Range
Dim rBreak As Range
Dim rObC As Range
Dim rTea As Range
Dim rST As Range
Dim rRow As Range
Dim rIntersection As Range
Dim rCell As Range
Set oWs = Worksheets("MyData") 'The worksheet where data resides
MaxBreakTime = oWs.Cells(1, 7).Value 'The max break time. I set it in cell G1. Change according to your needs
Set rAnalysts = oWs.Rows("3:9") 'Define the rows for analysts
Set rBreak = oWs.Range("B:F") 'define the columns where Break data is placed
'(similarly, set ranges for tea break, etc)
For Each rRow In rAnalysts.Rows 'for each row in the analyst range
sAnalystName = oWs.Cells(rRow.Row, 1).Value 'get the name of the analyst
lBreakTime = 0 'restart this variable to zero
Set rIntersection = Application.Intersect(rRow, rBreak) ' intersect the row (the analyst) with the columns of the Break range
If rIntersection Is Nothing Then
MsgBox "Ranges do not intersect. Something is radically wrong."
Else
For Each rCell In rIntersection.Cells 'id est, friday through thursday
If rCell.Value > MaxBreakTime Then 'if break was longer that stipulated,....
lBreakTime = lBreakTime + rCell.Value - MaxBreakTime 'add the excess to the variable
End If
Next
End If
'write data somewhere (here, 30 rows down from original Analysts range)
oWs.Cells(rRow.Row + 30, 1) = sAnalystName
oWs.Cells(rRow.Row + 30, 2) = lBreakTime
If lBreakTime > 0 Then
oWs.Cells(rRow.Row + 30, 2).Font.Color = vbGreen
oWs.Cells(rRow.Row + 30, 2).Interior.Color = vbRed
End If
Next
'Here something similar for Tea break and Outbounds calls
'Since output is already writen, you can reuse variables like rIntersection or rCell
End Sub

Search only rows within a color index

I'm new to VBA (somewhat) and I was assigned the tedious task of searching over 5000 rows to highlight rows (from A to j with the colorindex=6) based on a cell value and it's taking me forever. Basically I'm trying to develop a program that searches a string under column C, if the cell is equal to the string searched, then offset to 4 row below from the active cell and for any number greater than 37 and stops when it finds a cell in a row with the index color 33. Any ideas? I started and now stuck. Any ideas will help. Thanks
Sub Priority()
'Declaring all worksheets in the excel file
Dim US As Worksheet
Dim Venr50 As Worksheet
Dim Priority As Worksheet
Dim CBT As String
'setting all variables declared
Set US = Worksheets("US CKS")
Set Venr = Worksheets("VENR50 US 09.24")
Set Priority = Worksheets("Priority")
CBT = Priority.Range("$C$6").Value
With US
Dim x As Long
For x = 4 To 3000
If Cells(x, "C").Value = CBT Then
ActiveCell.Interior.ColorIndex = 33
ActiveCell.Offset(4, 0).Select
End If
You can do another loop within your For loop like below:
Dim x As Long
Dim j as integer
For x = 4 To 3000
If Cells(x, "C").Value = CBT Then
For j=1 to 4
If Cells(x+j,"C").Value>37 then Cells(x+j,"C").ColorIndex = 6
If Cells(x+j,"C").Interior.ColorIndex = 33 then exit sub
Next j
End If
If Cells(x+j,"C").Interior.ColorIndex = 33 Then Exit Sub
Next x
EDIT:
To change the color index of multiple rows you can use:
Range(Cells(x+j,"A"),Cells(x+j,"J")).Interior.ColorIndex = 6

For loop to copy entire row when match found between two sheets

I am trying to get a For loop which copies an entire row from worksheet 1 to worksheet 3 if the cell in column C in ws1 and column AT in ws2 matches. I have two issues:
1. It seems to be stuck in the For i = xxxxx loop and does not move to the next k (only copies one line 25 times)
2. When I use it on a sheet that has 100,000 rows for worksheet 1 and 15,000 rows on worksheet 2, excel just crashes. Is there a way to manage this?
Sub CopyBetweenWorksheets()
Application.ScreenUpdating = False
Dim i As Long, k As Long, ws1 As Worksheet, ws2 As Worksheet, myVar As String, myVar2 As String
Set ws1 = Worksheets("BOM")
Set ws2 = Worksheets("APT")
Set ws3 = Worksheets("Combined")
'get the last row for w2 and w1
ii = ws1.Cells.SpecialCells(xlCellTypeLastCell).row
kk = ws2.Cells.SpecialCells(xlCellTypeLastCell).row
For k = 2 To kk
myVar = ws2.Cells(k, 46)
For i = 688 To ii '688 To ii
myVar2 = ws1.Cells(i, 3)
If myVar2 = myVar Then
ws3.Rows(k).EntireRow.Value = ws1.Rows(i).EntireRow.Value 'copy entire row
Exit For
End If
Next i
Next k
End Sub
Your code is fine (not mentioning the missing Application.ScreenUpdating = True), but it will hang on large number of rows and columns because of the amount of interations with the application (Excel in this case).
Each time you request a value from a single cell from Excel, your code will hang for about 4 secounds per 1 million requests. From an entire row it will hang for 4 secounds per 4000 requests. If you try writing a single cell, your code will hang for 4 secounds per 175000 requests, and writing an entire row will hang your code for 4 secounds per 300 requests.
This way, only if you try parsing 15.000 rows of data from one sheet to another, your code will hang for about 3,3 minutes.. not to mention all read requests..
So, always keep the amount of interactions with any application from vba to a minimum, even if you have to create a much bigger code.
Here is what your code should look like if you want to handle a lot of data:
Sub CopyBetweenWorksheets2()
Dim aAPT, aBOM, aCombined As Variant
Dim lLastRow As Long, lLastColumn As Long
Dim i As Long, j As Long
Const APTColRef = 3
Const BOMColRef = 46
Const MAXCol = 200
'Speed up VBA in Excel
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Get the last row and column to use with the combined sheet
lLastRow = WorksheetFunction.Min(APT.Cells.SpecialCells(xlCellTypeLastCell).Row, BOM.Cells.SpecialCells(xlCellTypeLastCell).Row)
lLastColumn = WorksheetFunction.Min(MAXCol, WorksheetFunction.Max(APT.Cells.SpecialCells(xlCellTypeLastCell).Column, BOM.Cells.SpecialCells(xlCellTypeLastCell).Column))
'Parse all values to an array, reducing interactions with the application
aAPT = Range(APT.Cells(1), APT.Cells(lLastRow, lLastColumn))
aBOM = Range(BOM.Cells(1), BOM.Cells(lLastRow, lLastColumn))
'Creates a temporary array with the values to parse to the destination sheet
ReDim aCombined(1 To lLastRow, 1 To lLastColumn)
'Loop trough values and parse the row value if true
For i = 1 To lLastRow
If aAPT(i, APTColRef) = aBOM(i, BOMColRef) Then
For j = 1 To lLastColumn
aCombined(i, j) = aAPT(i, j)
Next
End If
Next
'Parse values from the destination array to the combined sheet
Combined.Range(Combined.Cells(1), Combined.Cells(lLastRow, lLastColumn)) = aCombined
'Disable tweaks
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub
!! I named the sheets objects in the VBA itself, so you don't have to declare a new variable and you also won't have any problems if you rename them later. So, insted of sheets("APT"), I just used APT (you will have to rename it too if you want the code to work) !!
Plus, here is my speed code I wrote for speed testing my codes. I always keep it at hand, and use it in almost every function i write
Sub Speed()
Dim i As Long
Dim dSec As Double
Dim Timer0#
Dim TimerS#
Dim TimerA#
Dim TimerB#
dSec = 4 ''Target time in secounds''
i = 1
WP1:
Timer0 = Timer
For n = 1 To i
SpeedTestA
Next
TimerA = Timer
For n = 1 To i
SpeedTestB
Next
TimerB = Timer
If TimerB - Timer0 < dSec Then
If TimerB - Timer0 <> 0 Then
i = CLng(i * (dSec * 2 / (TimerB - Timer0)))
GoTo WP1
Else
i = i * 100
GoTo WP1
End If
End If
MsgBox "Código A: " & TimerA - Timer0 & vbNewLine & "Código B: " & TimerB - TimerA & vbNewLine & "Iterações: " & i
End Sub
Sub SpeedTestA() 'Fist Code
End Sub
Sub SpeedTestB() 'Secound Code
End Sub

Why do my VBA code sometimes work and most of the times it doesn't?

Sub UpdateCSAH()
Dim S As String
Dim R As Long
Dim RR As Long
Dim CC As Long
Dim i As Long
Dim j As Long
Dim csah() As String 'an array that stores the CSAH sites
ReDim csah(1 To 100, 1 To 7)
Dim Ran As Range
Dim Ran1 As Range
Set Ran = Worksheets("Current Sites").Range("A1").CurrentRegion 'Ran is the region that has values
RR = 1 'row number in csah
CC = 1 'column number in csah
'check each value in Ran to see if its Route section has "CSAH"
For Each cell In Ran
R = cell.row
S = CStr(Cells(R, 4).value)
If InStr(S, "CSAH") > 0 Then 'check if "CSAH" is in the Route section
If CC > 7 Then 'reset the column number and go to the next row when reach the end of the column
CC = 1
RR = RR + 1
End If
csah(RR, CC) = cell.value
CC = CC + 1
End If
Next cell
Worksheets("CSAH Sites").Select
Range("A2:G100").Select
Selection.ClearContents
'assign each array values to cells in sheet"CSAH Sites"
i = 1
j = 1
For i = 1 To UBound(csah, 1)
For j = 1 To UBound(csah, 2)
Cells(i + 1, j) = csah(i, j)
Next j
Next i
'format the CSAH Sites values
Set Ran1 = Worksheets("CSAH Sites").Range("A1").CurrentRegion
For Each cell In Ran1
If cell.row = 1 Then
With cell.Font
.Color = -11489280
End With
ElseIf cell.row Mod 2 = 0 Then
With cell.Interior
.Color = 10092441
End With
End If
Next cell
End Sub
I have an Excel worksheet named "Current Sites" that has some data. If the 4th column has the word "CSAH", I want to store the values of that row into an array and assign those values to cells in the worksheet named "CSAH Sites". My code sometimes works (the 1st time you click), and most of times it doesn't work or doesn't work properly.
Please help me out! Thanks A Bunch!!
It looks like you want to check every row of data in the "Current Sites" sheet and if column 4 includes the "CSAH" text, then write the first 7 columns of data for that entry to the "CSAH Sites" sheet and add some colour to the even-numbered rows.
To check every row of data, you can read down just one column and use either the Offset or the Cells method to see the values of neighbouring cells. In your code you were "touching" every cell and each time you were then looking at the value in column 4 and also checking to see if the code had gone past column 7. That slows things down a lot and makes the code hard to understand.
You can also assign the values from a range of cells directly to another range of cells without using variables or an array.
See if this does what you want:
Sub UpdateCSAH()
Dim currentSitesRange As Range
Dim thisSiteRange As Range
Dim outputCell As Range
Dim numRowsOfData As Long
Const NUM_COLUMNS_OF_DATA As Integer = 7
Set currentSitesRange = Worksheets("Current Sites").Range("A1")
numRowsOfData = currentSitesRange.CurrentRegion.Rows.Count
Set currentSitesRange = currentSitesRange.Resize(RowSize:=numRowsOfData) 'currentSitesRange is the region that has values
Worksheets("CSAH Sites").Range("A2:G100").ClearContents
Set outputCell = Worksheets("CSAH Sites").Range("A2")
For Each thisSiteRange In currentSitesRange.Cells
' Look for "CSAH" in the Route section (column D)
If InStr(1, thisSiteRange.Offset(ColumnOffset:=3).Value, "CSAH", vbTextCompare) > 0 Then
' Found "CSAH" so write NUM_COLUMNS_OF_DATA columns of data to CSAH Sites sheet
outputCell.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Value = thisSiteRange.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Value
' Format the even-numbered rows
If outputCell.Row Mod 2 = 0 Then
With outputCell.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Interior
.Color = 10092441
End With
End If
Set outputCell = outputCell.Offset(RowOffset:=1)
End If
Next thisSiteRange
End Sub