I am writing a macro that recognizes the RGB value of a cell and then passes it as an argument to conditional formatting. The only issue is that using below:
RGBcolor1 = "RGB(" & CInt("&H" & Right(HEXcolor1, 2)) & _
", " & CInt("&H" & Mid(HEXcolor1, 3, 2)) & _
", " & CInt("&H" & Left(HEXcolor1, 2)) & ")"
where:
HEXcolor1 = Right("000000" & Hex(Sheet1.[LowColour].Interior.Color), 6)
The RGB value is a string, whereas in order to pass it as .Color, I need it to be a Long (Color = rgb(255, 0, 0)).
I am aware solutions exist where using Debug window is recommended to retrieve ?rgb(255,0,0), however, I would like to automate the process. I tried Clng() as well as .Evaluate() but they did not work.
Any help greatly appreciated!
You'll have to parse the string. You could use a regex or just make some simple replacements to isolate just the digits. For example:
strColor = "RGB(123, 0, 234)"
strColor = Replace(strColor, "RGB", "")
strColor = Replace(strColor, "(", "")
strColor = Replace(strColor, ")", "")
strColor = Replace(strColor, " ", "")
Dim a As Variant, c As Long
a = Split(strColor, ",")
c = a(0) * &H10000 + a(1) * &H100 + a(2)
Range("A1").Interior.Color = c
Or, with a regex (you'll have to add a reference to the Microsoft VBScript Regular Expressions 5.5 library):
With New RegExp
.Global = True
.Pattern = "[^\d,]" ' Remove anything that's not a digit or comma
Dim a As Variant, c As Long
a = Split(.Replace(strColor, ""), ",")
c = a(0) * &H10000 + a(1) * &H100 + a(2)
End If
Range("A1").Interior.Color = c
Edit:
Here's a quick but hacky way, using Eval() from the Microsoft Script Control:
With CreateObject("MSScriptControl.ScriptControl")
.Language = "VBScript"
Range("A1").Interior.Color = .Eval(strColor)
End With
You can convert it by using the val() function
Dim l as long
dim str as string
str = "111111"
l = val(str)
or
CLng(Val(str))
Related
I have code that parses out the last word on a string.
ie. Stack/Over/Flow will give me "Flow".
But I want to get "Over/Flow".
This is what I got, but only able to get "Flow"
arr(counter - 2) = "'" & mid(Text, InStrRev(Text, "/") + 1) & "'"
I would use Split()
Sub lastTwo()
Dim str As String
str = "Stack/Over/Flow"
Dim splt() As String
splt = Split(str, "/")
If UBound(splt) > 0 Then
Debug.Print splt(UBound(splt) - 1) & "/" & splt(UBound(splt))
End If
End Sub
Here is a function that does it:
Function lastParts(str As String, delim As String, x As Long) As String
Dim splt() As String
splt = Split(str, "/")
If UBound(splt) + 1 >= x Then
Dim t As String
t = "=INDEX(INDEX({""" & Join(splt, """;""") & """},N(IF({1},ROW(" & UBound(splt) - x + 2 & ":" & UBound(splt) + 1 & "))),),)"
lastParts = Join(Application.Transpose(Application.Evaluate(t)), delim)
Else
lastParts = str
End If
End Function
It has three parts, the string, the delimiter and the number of returns.
It can be called using your code:
arr(counter-2) = lastParts(Text,"/",2)
or from the worksheet
=lastParts(A1,"/",2)
Initially misread the question. You can nest InStrRev() calls
arr(counter - 2) = "'" & mid(Text, InStrRev(Text, "/",InStrRev(Text, "/")-1)+1) & "'"
In VBA, how do you convert text containing Unicode to HTML entities?
Eg. Test chars: èéâ👍 would be converted to Test chars: èéâ👍
In Excel, characters are stored using Unicode UTF-16. The "Thumbs up" character (👍) corresponds to the Unicode character U+1F44D, encoded as follows:
in UTF-16 (hex) : 0xD83D 0xDC4D (d83ddc4d)
in UTF-16 (decimal) : 55357 , 56397
The following function (and test procedure) should convert as expected:
Sub test()
txt = String2Html("Test chars: èéâ" & ChrW(&HD83D) & ChrW(&HDC4D))
debug.print txt ' -> Test chars: èéâ👍
End Sub
Function String2Html(strText As String) As String
Dim i As Integer
Dim strOut As String
Dim char As String
Dim char2 As String
Dim intCharCode As Integer
Dim intChar2Code As Integer
Dim unicode_cp As Long
For i = 1 To Len(strText)
char = Mid(strText, i, 1)
intCharCode = AscW(char)
If (intCharCode And &HD800) = &HD800 Then
i = i + 1
char2 = Mid(strText, i, 1)
intChar2Code = AscW(char2)
unicode_cp = (intCharCode And &H3FF) * (2 ^ 10) + (intChar2Code And &H3FF)
strOut = strOut & "&#x" & CStr((intCharCode And &H3C0) + 1) & Hex(unicode_cp) & ";"
ElseIf intCharCode > 127 Then
strOut = strOut & "&#x" & Hex(intCharCode) & ";"
ElseIf intCharCode < 0 Then
strOut = strOut & "&#x" & Hex(65536 + intCharCode) & ";"
Else
strOut = strOut & char
End If
Next
String2Html = strOut
End Function
To convert Unicode to Asci (eg: æ to æ)
Public Function UnicodeToAscii(sText As String) As String
Dim x As Long, sAscii As String, ascval As Long
If Len(sText) = 0 Then
Exit Function
End If
sAscii = ""
For x = 1 To Len(sText)
ascval = AscW(Mid(sText, x, 1))
If (ascval < 0) Then
ascval = 65536 + ascval ' http://support.microsoft.com/kb/272138
End If
sAscii = sAscii & "&#" & ascval & ";"
Next
UnicodeToAscii = sAscii
End Function
To convert Asci to Unicode (eg: æ to æ)
Public Function AsciiToUnicode(sText As String) As String
Dim saText() As String, sChar As String
Dim sFinal As String, saFinal() As String
Dim x As Long, lPos As Long
If Len(sText) = 0 Then
Exit Function
End If
saText = Split(sText, ";") 'Unicode Chars are semicolon separated
If UBound(saText) = 0 And InStr(1, sText, "&#") = 0 Then
AsciiToUnicode = sText
Exit Function
End If
ReDim saFinal(UBound(saText))
For x = 0 To UBound(saText)
lPos = InStr(1, saText(x), "&#", vbTextCompare)
If lPos > 0 Then
sChar = Mid$(saText(x), lPos + 2, Len(saText(x)) - (lPos + 1))
If IsNumeric(sChar) Then
If CLng(sChar) > 255 Then
sChar = ChrW$(sChar)
Else
sChar = Chr$(sChar)
End If
End If
saFinal(x) = Left$(saText(x), lPos - 1) & sChar
ElseIf x < UBound(saText) Then
saFinal(x) = saText(x) & ";" 'This Semicolon wasn't a Unicode Character
Else
saFinal(x) = saText(x)
End If
Next
sFinal = Join(saFinal, "")
AsciiToUnicode = sFinal
Erase saText
Erase saFinal
End Function
I hope this would be help someone,
I got this code from here
For didactic purposes I like to perform and display calculations in Excel. To display calculations I use the following VBA worksheet-function:
Function DisplayFormula(range_rng As Range) As String
Application.Volatile
If range_rng.HasArray Then
DisplayFormula = "<-- " & " {" & range_rng.FormulaArray & "}"
Else
DisplayFormula = "<-- " & " " & range_rng.FormulaArray
End If
End Function
This works, however, I'm stuck with the implementation of two modifications:
I would like to display the actual values that are called in range_rng.
I would like to display variables instead of the ranges. The variables would be assigned in a separate cell, next to the cell where they are called from (see graphic below).
Column "C" shows the (desired) output formats for DisplayFormula(B3):
You can try this brute force approach.
I can't say that this is optimized, but it can satisfy your two conditions above.
Function DisplayFormula2(r As Range, Optional o As Variant) As String
Dim a, b, z, x, y, w
Dim f As String, tf As String
Dim c As Range
Dim i As Integer
If IsMissing(o) Then o = 0
a = Array("+", "-", "/", "*", "%", "&", "^", "=", _
"<", ">", "<=", ">=", "<>", "(", ")")
f = r.FormulaArray: tf = f
For Each b In a
With Application.WorksheetFunction
tf = .Substitute(tf, b, "|")
End With
Next
z = VBA.Split(tf, "|")
For Each w In z
Debug.Print w
On Error Resume Next
Set c = Range(w)
On Error GoTo 0
If Not c Is Nothing Then
If IsArray(x) Then
ReDim Preserve x(UBound(x) + 1): x(UBound(x)) = w
ReDim Preserve y(UBound(y) + 1): y(UBound(y)) = c.Offset(0, o).Value2
Else
x = Array(w)
y = Array(c.Offset(0, o).Value2)
End If
End If
Set c = Nothing
Next
If IsArray(x) Then
For i = LBound(x) To UBound(x)
With Application.WorksheetFunction
f = .Substitute(f, x(i), y(i))
End With
Next
End If
DisplayFormula2 = IIf(r.HasArray, "<-- {" & f & "}", "<-- " & f)
End Function
By the way, I don't think you need to use .Volatile so I removed it.
It will recalculate as long as you set Calculation mode to Automatic.
Actual Formula in C3:C5:
C3: =DisplayFormula(B3)
C4: =DisplayFormula2(B4)
C5: =DisplayFormula2(B5,-1)
You can achieve that by changing the target cell to TEXT format. Try this:
Function DisplayFormula(range_rng As Range) As String
Application.Volatile
ActiveCell.NumberFormat = "#"
If range_rng.HasArray Then
DisplayFormula = "<-- " & " {" & range_rng.FormulaArray & "}"
Else
DisplayFormula = "<-- " & " " & range_rng.FormulaArray
End If
End Function
I am reading a file line by line in Excel VBA.
I have some strings for example,
" ooo"
" ooo "
I want to find the number of empty spaces in the front of the string. If I use Trim, it is removing empty spaces from both back and front of the string.
You could use the LTrim and RTrim functions. - I would assume that is faster, than looping through the string and doing character comparisons.
Public Function NumberOfLeadingSpaces(ByVal theString As String) As Long
NumberOfLeadingSpaces = Len(theString) - Len(LTrim(theString))
End Function
Public Function NumberOfTrailingSpaces(ByVal theString As String) As Long
NumberOfTrailingSpaces = Len(theString) - Len(RTrim(theString))
End Function
Function test(s As String) As Integer
Dim str As String
str = "[abcdefghijklmnopqrstuvwxyz0123456789]"
Dim spaceCounter As Integer
For i = 1 To Len(s)
If Not Mid(s, i, 1) Like str Then
spaceCounter = spaceCounter + 1
Else
Exit For
End If
Next i
test = spaceCounter
End Function
By popular request: Why use this function instead of Trim, LTrim, etc?
Well, to summarize the full explanation, not all spaces can be removed with Trim. But they will be removed with this function.
Consider this example (I'll borrow PhilS' solution for illustrative purposes):
Sub testSpaceRemoval()
Dim str1 As String
str1 = " " & Chr(32) & Chr(160) & "a"
Debug.Print Chr(34) & str1 & Chr(34)
Debug.Print NumberOfLeadingSpaces(str1)
Debug.Print test(str1)
End Sub
Result:
" a"
2
3
Here we can see that the string clearly contains 3 spaces, but the solution using LTrim only counted 2.
So, what to use?
Well, it depends. If you have a dataset where you know you won't get non-breaking characters, use Trim as much as you want! If you think you can get non-breaking characters, Trim alone will not be enough.
Characters to look out for are, quoted from the explanation linked above:
leading, trailing, or multiple embedded space characters (Unicode character set values 32 and 160), or non-printing characters (Unicode character set values 0 to 31, 127, 129, 141, 143, 144, and 157)
Trim can remove chr(32) (as demonstrated above) but not chr(160), because 32 is the regular space and 160 is a non-breaking space.
If you're a stickler for covering your behind, consider this total solution:
Function cleanSpecialCharacters(str As String) As String
bannedChars = Chr(127) & "," & Chr(129) & "," & Chr(141) & "," & Chr(143) & "," & Chr(144) & "," & Chr(157) & "," & Chr(160)
str = Application.WorksheetFunction.Clean(str)
str = Application.WorksheetFunction.Trim(str)
For Each c In Split(bannedChars, ",")
str = Replace(str, c, "")
Next
cleanSpecialCharacters = str
End Function
For OP's particular question, it would have to be a little more tailored.
Sub blanks()
cadena = Cells(1, 1)
i = Len(cadena)
Do Until Mid(cadena, i, 1) <> " "
If Mid(cadena, i, 1) = " " Then contador = contador + 1
i = i - 1
Loop
Cells(2, 1) = contador
End Sub
Sub main()
Dim strng As String
Dim i As Long
strng = " ooo "
i = 1
Do While Mid(strng, i, 1) = " "
i = i + 1
Loop
MsgBox "number of front empty spaces: " & i - 1
End Sub
or use LTrim function:
Sub main2()
Dim strng As String
strng = " ooo "
MsgBox "number of front empty spaces: " & Len(strng) - Len(LTrim(strng))
End Sub
I have a field called "sku" which uniquely identifies products on the table, there are about 38k products. I have a "sku generator" which uses other fields in the table to create the SKU. It's worked perfectly without an issue until I started producing SKUs for a large amount of products. I would launch the generator and it would stop around 15,000 and say "System Resource exceeded" and highlight the following code in the function:
Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'"))
I didn't have time to fully fix the issue, so a temporary fix for me was to split the database in two, and run the sku generator seperately on both files. Now that I have more time I want to investigate why exactly it gets stuck around this number, and if there's a possibility of fixing this issue (it would save some time with splitting files and then grouping them again). I also have an issue with it getting really slow at times, but I think it's because it's processing so much when it runs. Here is the function
Option Compare Database
Private Sub Command2_Click() 'Generate SKU
Command2.Enabled = False: Command3.Enabled = False: Command2.Caption = "Generating ..."
Me.RecordSource = ""
CurrentDb.QueryDefs("ResetSKU").Execute
Me.RecordSource = "loadsheet_4"
Dim rs As Recordset, i As Long
Set rs = Me.Recordset
rs.MoveLast: rs.MoveFirst
For i = 0 To rs.RecordCount - 1
rs.AbsolutePosition = i
rs.Edit
rs.Fields("sku") = SetSKU(rs)
rs.Update
DoEvents
Next
Command2.Enabled = True: Command3.Enabled = True: Command2.Caption = "Generate SKU"
End Sub
Public Function SetSKU(rs As Recordset) As String
Dim TempStr As String, TempSKU As String, id As Integer, Found As Boolean, ColorFound As Variant
id = 1: ColorFound = DLookup("Abbreviated", "ProductColors", "[Color]='" & rs.Fields("single_color_name") & "'")
TempStr = "ORL-" & UCase(Left(rs.Fields("make"), 2)) & "-"
TempStr = TempStr & Get1stLetters(rs.Fields("model"), True) & rs.Fields("year_dash") & "-L-"
TempStr = TempStr & "WR-"
TempStr = TempStr & IIf(IsNull(ColorFound), "?", ColorFound) & "-4215-2-"
TempStr = TempStr & rs.Fields("color_code")
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'"))
While Found = False
id = id + 1
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'"))
Wend
If id > 1 Then
' MsgBox TempSKU
End If
SetSKU = TempSKU
End Function
Public Function Get1stLetters(Mystr As String, Optional twoLetters As Boolean = False) As String
Dim i As Integer
Get1stLetters = ""
For i = 0 To UBound(Split(Mystr, " ")) 'ubound gets the number of the elements
If i = 0 And twoLetters Then
Get1stLetters = Get1stLetters & UCase(Left(Split(Mystr, " ")(i), 2))
GoTo continueFor
End If
Get1stLetters = Get1stLetters & UCase(Left(Split(Mystr, " ")(i), 1))
continueFor:
Next
End Function
Public Function ADDZeros(N As Integer, MAX As Integer) As String
Dim NL As Integer
NL = Len(CStr(N))
If NL < MAX Then
ADDZeros = "0" & N 'StrDup(MAX - NL, "0") & N
Else: ADDZeros = N
End If
End Function
Notes: This function also calls other functions as well that adds a unique identifier to the SKU and also outputs the first letter of each word of the product
Also I'm running on 64 bit access.
If you require any other info let me know, I didn't post the other functions but if needed let me know.
thanks.
I am not 100% sure how you have split the Database into two files and that you are running the generator on both files. However I have a few suggestion to the function you are using.
I would not pass the recordset object to this function. I would rather pass the ID or unique identifier, and generate the recordset in the function. This could be a good start for efficiency.
Next, declare all objects explicitly, to avoid library ambiguity. rs As DAO.Recordset. Try to make use of inbuilt functions, like Nz().
Could Get1stLetters method be replaced with a simple Left() function? How about ADDZeros method?
Using DLookup might be a bit messy, how about a DCount instead? Could the following be any use now?
Public Function SetSKU(unqID As Long) As String
Dim TempStr As String, TempSKU As String
Dim id As Integer
Dim ColorFound As String
Dim rs As DAO.Recordset
id = 1
Set rs = CurrentDB.OpenRecordset("SELECT single_color_name, make, model, year_dash, color_code " & _
"FROM yourTableName WHERE uniqueColumn = " & unqID)
ColorFound = Nz(DLookup("Abbreviated", "ProductColors", "[Color]='" & rs.Fields("single_color_name") & "'"), "?")
TempStr = "ORL-" & UCase(Left(rs.Fields("make"), 2)) & "-"
TempStr = TempStr & Get1stLetters(rs.Fields("model"), True) & rs.Fields("year_dash") & "-L-"
TempStr = TempStr & "WR-"
TempStr = TempStr & ColorFound & "-4215-2-"
TempStr = TempStr & rs.Fields("color_code")
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
While DCount("*", "Loadsheet", "[sku]='" & TempSKU & "'") <> 0
id = id + 1
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
Wend
If id > 1 Then
'MsgBox TempSKU'
End If
Set rs = Nothing
SetSKU = TempSKU
End Function