I have this code,
Dim str As String, Dim replaceStr As String, Dim counter as Integer
str = "I have the number 3"
For counter = 1 To 5
replaceStr = Replace(str, counter, 99)
Next counter
I want the replace function to catch when the counter = 3 so that it replaces the 3 with 99.
So far I am still getting "I have the number 3".
I have tried Replace(str, CStr(counter), 99) and still gives me the same results.
You are doing the replacement when counter equals 3 but then undoing the replacement in the next pass through the loop. If you change your code to:
Sub test()
Dim str As String, replaceStr As String, counter As Integer
str = "I have the number 3"
For counter = 1 To 5
replaceStr = Replace(str, counter, 99)
Debug.Print replaceStr
Next counter
End Sub
You will see the output:
I have the number 3
I have the number 3
I have the number 99
I have the number 3
I have the number 3
Perhaps you can add the line If replaceStr <> str Then Exit For immediately after the Replace
You can apply the change to the actual string and not keep bringing in a "fresh" str.
Option Explicit
Sub test()
Dim str As String, replaceStr As String, counter As Long
str = "I have the number 3"
For counter = 1 To 5
str = Replace(str, counter, 99)
Next counter
Debug.Print str
End Sub
Related
Newbie here. I have an HTML source code and would like to look for string in between header tags <h1></h1>, <h2></h2>till <h5></h5> and then convert the text to lower case except acronyms or abbreviations (these are all capitals in 2 or more characters). And make sure that all country names in between use proper case.
As an example: It will find <h1>HR Policies and Procedures for Hiring - argentina LTD</h1>
It will convert it to:<H1>HR policies and procedures for hiring - Argentina LTD</H1>
I've tried a user defined function for Excel VBA found online: CapIt(A2). It uses Search, Split and Join. I'm not able to put them together to come up with the result. Would appreciate very much your help. Thank you.
Code I saw online as initial reference:
Function Capit(s As String)
Dim v As Variant, j As Long
v = Split(s, " ") ' separates the words
For j = LBound(v) To UBound(v)
If StrComp(v(j), UCase(v(j)), vbBinaryCompare) <> 0 Then v(j) = StrConv(v(j), vbProperCase)
Next j
Capit = Join(v, " ") ' joins the words
End Function
'Added this code below, can we use the results to lowercase the string and exclude the output in this function
Function FindAcronyms(yourWord As String)
Dim I As Integer
Dim ctr As Integer
FindAcronyms = Null
For I = 1 To Len(yourWord)
If Asc(Mid(yourWord, I, 1)) <= 90 And _
Asc(Mid(yourWord, I, 1)) >= 65 Then
If ctr > 0 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1)
End If
ctr = ctr + 1
Else
If ctr > 1 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1) & ", "
End If
ctr = 0
End If
Next
If ctr > 1 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1)
End If
If Right(FindAcronyms, 2) = ", " Then
FindAcronyms = Left(FindAcronyms, Len(FindAcronyms) - 2)
End If
End Function
'the final look would be something like this
Sub TitleChange()
'define array
myarray = Range("A1:A100")
' Define the pattern
Dim pattern As String: pattern = "<h*>*</h*>" 'looks for the header tags
Dim f As Variant
For Each f In myarray
If f Like pattern = True Then Capital (f) 'changes all string to lower case except countries (to retain proper case) and acronyms (to retain uppercase)
Next f
End Sub
You can include the countries in an array
Sub Test()
Debug.Print Capital("HR Policies and Procedures for Hiring - argentina LTD")
End Sub
Function Capital(ByVal s As String)
Dim a, v As Variant, j As Long
a = Array("Argentina", "Egypt", "Enland")
v = Split(s, " ")
For j = LBound(v) To UBound(v)
If StrComp(v(j), UCase(v(j)), vbBinaryCompare) <> 0 Then v(j) = StrConv(v(j), vbLowerCase)
If Not IsError(Application.Match(v(j), a, 0)) Then v(j) = StrConv(v(j), vbProperCase)
Next j
Capital = Join(v, " ")
End Function
Added UDF that parses HTML code, used the Sub Test above as UDF Capital and UDF to bring together. Welcome suggestions to make it cleaner or more efficient
Dim rng As Range, cell As Range
Set rng = Range("A1:A5")
' Define the pattern
Dim pattern As String: pattern = "*<h?>*</h?>*"
' Check each item against the pattern
For Each cell In rng
If (cell Like pattern = True) Then
cell.Offset(0, 16).Value = cell.Value
cell.Offset(0, 16).Value = joinCell(Capital(StripHTML(cell)), cell.Offset(0, 0).Value) 'used UDF for striping innertext, applying rules and joining back string
End If
Next cell
End Sub
My String (strSQL) Value is 1,2,3,,4 and My result shows blank between 3 and 4 due to Double comma (,,). My Code is Following:-
strParts = Split(strSQL, ", ")
For intCounter = LBound(strParts()) To UBound(strParts())
Me.Controls("cmd" & intCounter).Visible = True
Me.Controls("cmd" & intCounter).Caption = strParts(intCounter)
Next intCounter
You can replace a double (,,) by a single one (,) before splitting:
strSQL = Replace(strSQL, ",,", ",")
Or you use a separate index:
strParts = Split(strSQL, ",")
Dim index As Long
Dim counter As Long
For index = LBound(strParts()) To UBound(strParts())
If Len(Trim(strParts(index))) > 1 Then
counter = counter + 1
Me.Controls("cmd" & counter).Visible = True
Me.Controls("cmd" & counter).Caption = strParts(index)
End If
Next index
As you also could have tripled commas, just ignore the empty entries:
Dim Part As String
strParts = Split(strSQL, ",")
For intCounter = LBound(strParts()) To UBound(strParts())
Part = Trim(strParts(intCounter))
If Part <> "" Then
Me.Controls("cmd" & Part).Visible = True
Me.Controls("cmd" & Part).Caption = Part
Else
Me.Controls("cmd" & Part).Visible = False
End If
Next
I think the best way to do this is to "sanitize" your string to remove extra commas before splitting. However, as #Gustaf notes, you could have more than 2 commas in a row. So a possible solution is to iteratively remove extra commas until you don't have any. Such a function looks like this:
' given a string that contains consecutive commas (e.g. abc,,def,,,ghi),
' removes all but the first commas (e.g. abc,def,ghi
Public Function RemoveDuplicateCommas(ByVal s As String) As String
Do While InStr(1, s, ",,", vbBinaryCompare) > 0
s = Replace(s, ",,", ",")
Loop
RemoveDuplicateCommas = s
End Function
To use this function, do something like this:
strSQL = "1,2,3,,4,,,5"
strSQL = RemoveDuplicateCommas(strSQL)
?strSQL
1,2,3,4,5
?join(split(strsql, ","), ",")
1,2,3,4,5
I need a very simple hash-function and based on some experiments with excel just a sum of byte values should do it:
Function HashPart(strVal As String) As Long
' work with byte representation for speed
Dim b() As Byte
b = strVal
Dim result As Long
result = 0
For i = 0 To UBound(b)
result = result + b(i)
Next
Quersumme = result
End Function
This is done many time over all records (about 100) resulting from a query:
Set rs = db.OpenRecordset(strSQL)
' Loop through records
Do While Not rs.EOF
resultHash = resultHash + HashPart(rs(0))
resultLen = resultLen + Len(rs(0))
rs.MoveNext
Loop
rs.Close
MyHash = Str(resultLen) & "-" & Str(resultHash)
This works well enough, but is very slow. My previous version iterating over the String using Mid was even slower, but now I am out of ideas how to improve this.
Is there a way to speed this up?
Edit: the problem wasn't in the hash function but in the query.
Test code with constant strings showed that the function itself is very fast. 10,000 calls with strings of ca. 110 characters take only 0.04 seconds.
Conclusion: the performance problem was in the query, not the hash function.
Function HashPart(strVal As String) As Long
' work with byte representation for speed
Dim b() As Byte
Dim result As Long
Dim i As Long
b = strVal
result = 0
For i = 0 To UBound(b)
result = result + b(i)
Next
HashPart = result
End Function
Sub TestHashPart()
Const NumRounds = 10000
Dim i As Long
Dim res As Long
Dim SumRes As Double ' avoid limitation of Long (2^31)
Dim S As String
Dim t1 As Single
t1 = Timer
For i = 1 To NumRounds
' constant string with tiny variations
S = "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ " & CStr(i ^ 2)
res = HashPart(S)
' This would slow down the process dramatically. DO NOT activate for NumRounds > 1000 !
' Debug.Print i, res, Len(S), S
SumRes = SumRes + res
Next i
Debug.Print SumRes, Timer - t1 & " seconds"
End Sub
Function HashPart(strVal As String) As Long
' work with byte representation for speed
Dim b() As Byte
b = strVal
For i = 0 To UBound(b)
HashPart = HashPart + b(i)
Next
End Function
There's not much to improve, I think if you don't put the additional variable in there and don't set a number to 0 that defaults to 0 you're very slightly better off.
I have a stupid question, I always got the error type mismatch when I created a function which return a array. here are two simple example :
if I don't declare the type when declaration: It will be compiled, but got the error after the function result
Function aa(c As Integer)
Dim arr(10)
Dim i As Integer
Dim k As Double
For i = 0 To 10
k = i ^ 2 / c + 1
arr(i) = CStr(k)
Debug.Print k
Next i
aa = arr
End Function
if i declare the type: it can't be compiled and will get the error directly
Function aa(c As Integer) as string()
Dim arr(10) as string
Dim i As Integer
Dim k As Double
For i = 0 To 10
k = i ^ 2 / c + 1
arr(i) = CStr(k)
Debug.Print k
Next i
aa = arr
End Function
Your second version will work if you call it this way, using the same type:
Sub Testaa()
Dim result() As String
result = aa(4)
End Sub
Your first version will return a Variant - any function (or variable) that isn't given a specific type will default to Variant. So you need to store the return result in a Variant as well:
Sub Testaa()
Dim result As Variant
result = aa(4)
End Sub
It is preferable to use explicit types wherever possible.
I have a data chart with many products.
I want to filter each type of product, calculate the total quantity of that type as well as the number of product inside that type. And finally put the value of that function into a column in Sheet 2.
Here is the code. The quantity column is column U. It gets error 1004: Argument not optional, and it highlights the Set .... = FunctionR1C1 = .... part
Function T_Quantity()
ActiveSheet.Range("U").Select
Total = FunctionR1C1 = "=subtotal(9,C[0])"
End Function
Function T_Count(ref_column)
ActiveSheet.Range("U").Select
Total = FunctionR1C1 = "=subtotal(2,C[0])"
End Function
Sub Total_Count()
Dim my_array() As String
Dim iLoop As Integer
Dim iCount As Integer
iCount = 1
ReDim my_array(3)
my_array(0) = "=M1747B"
my_array(1) = "=M1747C"
my_array(2) = "=M1766B"
For iLoop = LBound(my_array) To UBound(my_array)
ActiveSheet.Range("A:BB").Select
Selection.AutoFilter Field:=15, Criteria1:=my_array
Application.CutCopyMode = False
'Calculate the quantity and no of lot, put in colum A,B in sheet 2'
Set Worksheets("Sheet2").Cells(iCount, 1) = T_Quantity()
Set Worksheets("Sheet2").Cells(iCount, 2) = T_Count()
Application.CutCopyMode = False
iCount = iCount + 1
Next iLoop
End Sub
Let's start with this and see if that gets you any closer to your desired results:
Sub Total_Count()
Dim my_array() As String
Dim iLoop As Integer
Dim iCount As Integer
iCount = 1
ReDim my_array(3)
my_array(0) = "=M1747B"
my_array(1) = "=M1747C"
my_array(2) = "=M1766B"
For iLoop = LBound(my_array) To UBound(my_array)
ActiveSheet.Range("A:BB").Select
Selection.AutoFilter Field:=15, Criteria1:=my_array
Application.CutCopyMode = False
'Calculate the quantity and no of lot, put in colum A,B in sheet 2'
Worksheets("Sheet2").Cells(iCount, 1).FormulaR1C1 = "=subtotal(9,C[0])"
Worksheets("Sheet2").Cells(iCount, 2).FormulaR1C1 = "=subtotal(2,C[0])"
Application.CutCopyMode = False
iCount = iCount + 1
Next iLoop
End Sub
What I changed:
Eliminate the Set keyword when working with cell objects on the Worksheet. Set is used to assign object variables.
Since the functions you call appear to be simply setting the cell's FormulaR1C1 property, I add the .FormulaR1C1 property to those lines, and then, instead of using a Function, I simply put the function's R1C1 notation directly in this subroutine.