So I am lookingto convert this formula =IF(A3,IF(ISNUMBER(C3/B3),C3/B3,""),"")
into a private function so I can use that instead. I have tried and failed to get it to work in VBA, if it is numeric and it is, how can I perform the division from the two cells?
Code:
Function GetSpendPerHead(Ra As Range, rb As Range, rc As Range)
GetSpendPerHead = ""
If Ra.Value = True Then
If IsNumeric(rb.Value) And IsNumeric(rc.Value) Then
If rb.Value <> 0 Then
GetSpendPerHead = rc / rb
End If
End If
End If
End Function
Your function seems to work fine for me, here are some test cases.
Sub UnitTestGetSpendPerHead()
Dim ra As Range: Set ra = Range("A1")
Dim rb As Range: Set rb = Range("B1")
Dim rc As Range: Set rc = Range("C1")
Dim test As Variant
rb.NumberFormat = "General"
' Test 1
ra.Value2 = ""
rb.Value2 = 1
rc.Value2 = 2
test = GetSpendPerHead(ra, rb, rc)
Debug.Print "Test 1 Result: " & test
' Test 2
ra.Value2 = 2014
rb.Value2 = 2
rc.Value2 = "a"
test = GetSpendPerHead(ra, rb, rc)
Debug.Print "Test 2 Result: " & test
' Test 3
ra.Value2 = 2015
rb.NumberFormat = "#"
rb.Value2 = "4"
rc.Value2 = 2
test = GetSpendPerHead(ra, rb, rc)
Debug.Print "Test 3 Result: " & test
End Sub
Function GetSpendPerHead(ra As Range, rb As Range, rc As Range)
GetSpendPerHead = ""
If Not IsEmpty(ra.Value) Then
If IsNumeric(rb.Value) And IsNumeric(rc.Value) Then
If rb.Value <> 0 Then
GetSpendPerHead = rc / rb
End If
End If
End If
End Function
Function CheckNumber()
'Define the variables
Dim FirstNumber As Double
Dim SecondNumber As Double
Dim Result As Double
'If we have an error when are reading the variables go to Oops
On Error GoTo Oops
'Read the first number from row 3 and column 3 (C)
FirstNumber = Sheets("Sheet1").Cells(3, 3).Value
'Read the first number from row 3 and column 2 (B)
SecondNumber = Sheets("Sheet1").Cells(3, 2).Value
'Calculate C3/B3
Result = FirstNumber / SecondNumber
'Get the result as message box
MsgBox Result
'If we have error we get this message: Not Number
Oops:
MsgBox "Not Number"
End Function
Thanks all, after debugging, problem was instead or Ra.Value = true , I then set Ra.Value = 1 and it worked
Related
I am trying to exclude all zero values from my standard deviation calculations. For instance, if my data range has three numbers: 0,1,2 then I only want to calculate the standard deviation of 1 and 2.
Here is my current code (for reference- the top portion of my code is being used to reference certain cell names, that way the ensuing data is properly pulled):
Sub DownsideSTDVCalc()
Dim fund As String
Dim checkFund
Dim item As String
fund = Worksheets(12).Range("A2").Value
For i = 2 To 48
checkFund = Worksheets(11).Columns(i)
item = Worksheets(11).Columns(i).Cells(1, 1)
If item = fund Then
Dim values
Dim qtd
values = Worksheets(11).Range(Worksheets(11).Cells(2, i), Worksheets(11).Cells(4, i))
For j = 1 To UBound(values) - LBound(values)
values(j, 1) = values(j, 1)
Next
qtd = Application.WorksheetFunction.StDev_S(values)
Worksheets(12).Range("b2").Value = qtd
End If
Next
End Sub
For example:
Sub Tester()
Debug.Print StdDevNoZero(Selection)
End Sub
Function StdDevNoZero(rng As Range)
Dim f, addr
addr = rng.Address(False, False)
f = "STDEV.S(IF(" & addr & ">0," & addr & "))"
StdDevNoZero = rng.Parent.Evaluate(f)
End Function
I have multiple rows with some words separeted by semicolons(;), and need to count how many times a certain word appears in Column A cell strings of Sheet1.
Using two rows for example:
Column "A"
Banana; Apple; Orange
Banana; Banana; Apple
I came up with this code for the counting of the specific word I want to count:
Sub count()
'The count will be registered in "B6"
strcount = "Banana"
For i = 2 to 30
If InStr(Sheets("Sheet1").Cells(i, "A").Text, strcount) <> 0 Then
Cells(6, "B").Value = Cells(6, "B").Value + 1
End If
Next i
End Sub
The problem with this code is that it doesn't recognize the 2 appearences of "Banana" in the second row returning me a count of 2 instead of 3:
Results for each fruit:
Banana: 2
Apple: 2
Orange: 1
I see that the problem is InStr only recognizes if the string is there, but how can I overcome this?
Solution:
Both basodre's and Алексей's answers worked.
For basodre's code I had to change only the delimiter from ";" to "; " (with a space after the semicolon) to match my string.
aFoods = Split(rIterator.Value, "; ")
Алексей's answer works perfectly too, but by the time of this edit is limited for Excel 2019 or above, given it uses the "TEXTJOIN" function and I couldn't come up with a replacement for that.
Here's an example that I think does what you need. Please review, modify to your range, and let us know if it works.
Sub CountWords()
Dim rng As Range
Dim aFoods As Variant
Dim rIterator As Range
Dim counter As Long
Const theFood As String = "Banana"
Set rng = Range("A1:A3")
counter = 0
For Each rIterator In rng
aFoods = Split(rIterator.Value, ";")
For i = LBound(aFoods) To UBound(aFoods)
If aFoods(i) = theFood Then
counter = counter + 1
End If
Next i
Next rIterator
Debug.Print counter
End Sub
Solution with RegExp:
Option Explicit
Sub test1()
Dim re As Object, result As Object, text As String, fruit As Variant
Set re = CreateObject("vbscript.regexp")
re.Global = True
text = WorksheetFunction.TextJoin(";", True, Columns("A"))
'In Excel < 2019 you can use: text = Join(WorksheetFunction.Transpose(Intersect(Columns("A"), ActiveSheet.UsedRange)), ";")
For Each fruit In Array("Banana", "Apple", "Orange")
re.Pattern = "\b" & fruit & "\b"
Set result = re.Execute(text)
Debug.Print "Amount of [" & fruit & "] = " & result.Count
Next
End Sub
Output:
Amount of [Banana] = 3
Amount of [Apple] = 2
Amount of [Orange] = 1
Using regular expression
Sub FindEntries()
Dim mc, rw
Const word$ = "Banana"
With CreateObject("VBScript.RegExp")
.IgnoreCase = True: .Global = True: .Pattern = "(^|;\s+)" & word & "(?=;|$)"
For rw = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Set mc = .Execute(Cells(rw, "A")): [B6] = [B6] + mc.Count
Next
End With
End Sub
I have a workbook where I want to find the differences of two sheets by looking at the company name and their corporate registration number and then type the differences on the third sheet.
I have tried the code in another workbook with only 143 rows, which works perfectly, but when I try it on the real workbook with 10,000 rows I get a "type mismatch error". Also if I use other columns than the CVR and Firm columns the code also works.
The CVR is numbers and Firms are strings (firm names). I get the
type mismatch error
on the line I marked **. Does somebody know why I get this error?
Sub ComCVR()
Dim CVR1()
Dim CVR2()
Dim Firm1()
Dim Firm2()
Dim n As Long, m As Long
Dim i As Double, j As Double
Dim intCurRow1 As Integer, intCurRow2 As Integer
Dim rng As Range, rng1 As Range
Set rng = ThisWorkbook.Sheets("Last month").Range("A11")
Set rng1 = ThisWorkbook.Sheets("Current month").Range("A11")
n = rng.CurrentRegion.Rows.Count
m = rng1.CurrentRegion.Rows.Count
ReDim CVR1(n)
ReDim Firm1(n)
ReDim CVR2(m)
ReDim Firm2(m)
ThisWorkbook.Sheets("CVR").Range("A1") = "Flyttet CVR"
ThisWorkbook.Sheets("CVR").Range("B1") = "Flyttet Firmanavn"
ThisWorkbook.Sheets("CVR").Range("A1:B1").Interior.ColorIndex = 3
ThisWorkbook.Sheets("CVR").Range("C1") = "Nye CVR"
ThisWorkbook.Sheets("CVR").Range("D1") = "Nye Firmanavn"
ThisWorkbook.Sheets("CVR").Range("C1:D1").Interior.ColorIndex = 4
ThisWorkbook.Sheets("CVR").Range("A1:D1").Font.Bold = True
' Inset data to arrays
For i = 0 To n
CVR1(i) = ThisWorkbook.Sheets("Last month").Cells(12 + i, 5)
Firm1(i) = ThisWorkbook.Sheets("Last month").Cells(12 + i, 4)
Next
For i = 0 To m
CVR2(i) = ThisWorkbook.Sheets("Current month").Cells(12 + i, 5)
Firm2(i) = ThisWorkbook.Sheets("Current month").Cells(12 + i, 4)
Next
intCurRow1 = 2
intCurRow2 = 2
'Old
For i = 0 To n
For j = 0 To m
If Firm1(i) = ThisWorkbook.Sheets("Current month").Cells(12 + j, 4) Then '** Error raised here
Exit For
End If
If j = m Then
ThisWorkbook.Sheets("CVR").Cells(intCurRow1, 1) = CVR1(i)
ThisWorkbook.Sheets("CVR").Cells(intCurRow1, 2) = Firm1(i)
intCurRow1 = intCurRow1 + 1
End If
Next j
Next i
'new
For i = 0 To m
For j = 0 To n
If Firm2(i) = ThisWorkbook.Sheets("Last month").Cells(12 + j, 4) Then
Exit For
End If
If j = n Then
ThisWorkbook.Sheets("CVR").Cells(intCurRow2, 3) = CVR2(i)
ThisWorkbook.Sheets("CVR").Cells(intCurRow2, 4) = Firm2(i)
intCurRow2 = intCurRow2 + 1
End If
Next j
Next i
Columns("A:B").Select
ActiveSheet.Range("$A:$B").RemoveDuplicates Columns:=1, Header:=xlNo
Application.DisplayAlerts = False
Columns("C:D").Select
ActiveSheet.Range("$C:$D").RemoveDuplicates Columns:=1, Header:=xlNo
Application.DisplayAlerts = False
End Sub
Whenever an error happens, the best way is to google it. This is what it says in the documentation of VBA for Type mismatch:
Cause: The variable or property isn't of the correct type. For example, a variable that requires an integer value can't accept a string value unless the whole string can be recognized as an integer.
In the case of the code, it happens, when an array is compared with excel cell. Now the trick - in order to see why it happens, see what is in these:
Debug.Print ThisWorkbook.Sheets("Last month").Cells(12 + i, 4)
Debug.Print Firm1(i)
and the after the error runs, take a look at the immediate window (Ctrl+G). It it quite possible, that there is an error in the excel cell, thus it cannot be compared. This is some easy way to avoid it, if this is the case:
Sub TestMe()
Dim myRange As Range
Set myRange = Worksheets(1).Cells(1, 1)
myRange.Formula = "=0/0"
If Not IsError(myRange) Then
Debug.Print CBool(myRange = 2)
Else
Debug.Print myRange.Address; " is error!"
End If
End Sub
Basically I have 7 cells that could be populated with text (b2, b4, b6, b8, b10, b12 and b14). I want to the code to check each of the cells to see if they have a value and send only the cells that do have a value in an email. For formatting purposes the cells pasted into the email need to have one empty cell in between and the cells need to be kept in the order they are in originally, just without the unnecessary blank cells.
I've never officially learned VBA I've only taught myself on a case by case scenario so there could be an easy solution that I'm missing. Often I can debug and find the problem but in this case Excel completely freezes and turns "Not Responding". I have a feeling that means I've got a loop somewhere unresolved but I don't really understand how. The code -seems- to run up until Range("A2").Value = Line(LineCount1). Any suggestions would be appreciated.
Public Sub SingleEmail()
Dim LineCount1 As Integer
Dim LineCount2 As Integer
Dim LineCount3 As Integer
Dim LineCount4 As Integer
Dim LineCount5 As Integer
Dim LineCount6 As Integer
Dim LineCount7 As Integer
Dim NumOfLines As Integer
Range("A2", "A14").ClearContents
LineCount1 = 2
Range("A2").Value = Line(LineCount1)
LineCount2 = 2 + LineCount1
Range("A4").Value = Line(LineCount2)
LineCount3 = 2 + LineCount2
Range("A6").Value = Line(LineCount3)
LineCount4 = 2 + LineCount3
Range("A8").Value = Line(LineCount4)
LineCount5 = 2 + LineCount4
Range("A10").Value = Line(LineCount5)
LineCount6 = 2 + LineCount5
Range("A12").Value = Line(LineCount6)
LineCount7 = 2 + LineCount6
Range("A14").Value = Line(LineCount7)
NumOfLines = Range("n3").Value
If Range("A2") <> "" Then
Range("A2", "A" & NumOfLines).Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = ""
.Item.To = "personalemailaddress#Someplace.com"
.Item.CC = ""
.Item.Subject = "Email Subject"
.Item.send
End With
End If
End Sub
Function Line(ByRef LineCount As Integer) As String
Line = ""
Do While Line = "" Or LineCount < 13
If Range("B" & LineCount).Value <> "" Then
Line = Range("B" & LineCount).Value
Else
LineCount = LineCount + 2
End If
Loop
End Function
To answer your question:
If B4 has value and B2 is blank then this While loop become infinite. the LineCount is Stuck on 4, hence no overflow. That's why your code freezes.
Why are you running a loop in the first place. You can simply assign the values like this Range("A2:A14").Value =Range("B2:B14").Value
As per your comment, you need to use And operator in place of OR
Do While Line = "" And LineCount < 13 now the loop will exit if line <> "" or LineCount > 14
I have some vba code to grab information 4 times a minute from a device on it's web configuration page.
I need this to happen from when I place an x in column C and continue until I place an x in column D further down the page.
I have a function I can call which will tell if an X is in the proper place in d, relative to c.
What I'd like to do is have a button which says ok, be ready to scan. then have it start when the first value is entered in c, then stop when the d value is entered.
I'm also having trouble coming up with a way to enter values while the VBA script is actually running.
Any advice? Thanks.
Here is the code to check the columns.
Public Function BackgroundScan(MonitorSpreadsheet As Boolean) As Boolean
Dim LastStart As Integer
Dim LastStop As Integer
intDebug = 1
Select Case MonitorSpreadsheet
Case True
'We are actively testing
If intDebug = 1 Then MsgBox "we ARE monitoring the spreadsheet."
'Call scanning routine here
'Get the status TestingInProgress
LastStart = FindLastStartRow("SVQ")
LastStop = FindLastStopRow("SVQ")
If intDebug = 1 Then MsgBox "LastStart " & LastStart
If intDebug = 1 Then MsgBox "LastStop " & LastStop
Select Case LastStart
Case Is < 20
'We have not started.
If intDebug = 1 Then MsgBox "We have not started."
BackgroundScan = False
'Loop around, and check again
Case Else
'ok we have started, now check to see if we have stopped.
Select Case LastStop
Case Is < LastStart
'**** We ARE testing!!! ****
If intDebug = 1 Then MsgBox "We are testing, and haven't finished."
BackgroundScan = True
Case LastStart
'LastStart and LastStop are the same line, we have started AND finished
If intDebug = 1 Then MsgBox "We have started AND finished!"
BackgroundScan = False
'Loop around, and check again
Case Else
'We have finished testing, and the test spanned multiple rows
BackgroundScan = False
If intDebug = 1 Then MsgBox "We started on one line, and finished on another."
End Select
End Select
Case False
'we are not actively testing
If intDebug = 1 Then MsgBox "We are NOT monitoring the spreadsheet."
BackgroundScan = False
Case Else
MsgBox "Error: Boolean variable reports: " & MonitorSpreadsheet
BackgroundScan = False
End Select
End Function
Here is the code which scans the webpage.
Private Sub CommandButton1_Click()
Dim Some As String 'can't resist a good pun!
Dim intDelay As Integer
Dim intMinDelay As Integer
Dim i As Integer
Dim s As Integer
Dim RunStart As Date
Dim WhichSVBeam As String
Dim lLen As Integer
Dim CurrentSVID As String
Dim CurrentBeamID As String
Dim PreviousSVID As String
Dim PreviousBeamID As String
Dim ColonLocation As Integer
'*******************************************************
'*** Test Continuous Button ***
'*** Where n is specified in cell A6 ***
'*******************************************************
'grab the number of minutes between checking values
intMinDelay = GetValues("A7")
RunStart = Now
'Do this until the end of time, or the execution is halted.
Do 'uncomment do when we are sure the DoEvents will work as we expect
WhichSVBeam = Scan_SVBeam(PreviousSVID, PreviousBeamID)
If InStr(WhichSVBeam, ":") Then
lLen = Len(WhichSVBeam)
ColonLocation = InStr(WhichSVBeam, ":")
'MsgBox WhichSVBeam & ", " & ColonLocation
CurrentSVID = Left(WhichSVBeam, ColonLocation - 1)
'MsgBox CurrentSVID
CurrentBeamID = Right(WhichSVBeam, lLen - ColonLocation)
'MsgBox CurrentBeamID
Else
'no colon, nothing to parse (this shouldn't happen)
MsgBox "No ':' from Scan_SVBeam"
End If
'Call sCheckExecutionTimeGap(RunStart)
'loop for the number of minutes we specified
For i = 1 To intMinDelay
'check every second for events
For s = 1 To 240
Call AppSleep(250)
DoEvents
Next s
Next i
Loop
End Sub
A example of a piece of code that will run at regular intervals, and allows you to change values in your spreadsheet that will be checked, is the following:
Sub testCell()
Dim r1, r2 As Integer
Dim stopIt As Boolean
r1 = doWeStart
r2 = doWeStop(r1)
Debug.Print "The value of cell C1 is now " & [C1].Value
If r1 = 0 Then Debug.Print "We haven't started yet"
If r1 > 0 And r2 = 0 Then Debug.Print "We start but don't stop"
If r1 > 0 And r2 > 0 Then Debug.Print "We started and stopped"
If [C1].Value Like "stop" Or r1 > 0 And r2 > 0 Then stopIt = True Else stopIt = False
If Not stopIt Then
Application.OnTime Now + TimeValue("00:00:05"), "testCell"
End If
End Sub
'
Function doWeStart()
Dim xrow As Integer
' save old selection
Set r = Selection
xrow = 0
' search for "x" in column C
On Error Resume Next
xrow = Application.WorksheetFunction.Match("x", [C:C], 0)
doWeStart = xrow
End Function
'
Function doWeStop(r1)
Dim xrowd As Integer
xrowd = 0
' search for "x" in column D, starting at row r1
On Error Resume Next
xrowd = Application.WorksheetFunction.Match("x", Range("D" & r1, "D1048576"), 0)
If xrowd > 0 Then
doWeStop = xrowd + r1 - 1
Else
doWeStop = 0
End If
End Function
This will run every five seconds, will look for the first "x" in column C and the first "x" in column D below the one found in C. Depending on what is there, it will (for now) print a message in the debug window - you can put your code there. When you enter "stop" in C1, or an "x" is found in both C and D, it stops.
in pseudo code it would be something along th lines of:
start when column c=x
begin loop
get data
check value of column d
if column d= x exit loop
next loop iteration
end
is that what you want?
Philip