My vba code should organiza a balance sheet I just pasted o Excel from a PDF. So, like most balance sheets, there are the description of the item (asset/liabilities/etc) and the values from the years that are being analyzed.
First, I was trying to identify in which position the text ended. So I wrote the following code, which is giving me and error (Invalid Qualifier).
Dim subjectCell As String
Dim letters As String
Dim index As Integer
letters = "qwertyuiopasdfghjklçzxcvbnmQWERTYUIOPASDFGHJKLÇZXCVBNM "
subjectCell = ActiveCell.Value
For i = 0 To Len(subjectCell) - 1
If (letters.Contains(Mid(subjectCell, i + 1, 1))) Then
Else
index = i
Next i
Cell("A1").Value = index
Sub test()
Dim subjectCell As String
Dim letters As String
Dim index As Integer
letters = "qwertyuiopasdfghjklçzxcvbnmQWERTYUIOPASDFGHJKLÇZXCVBNM "
subjectCell = ActiveCell.Value2
For i = 1 To Len(subjectCell)
If InStr(1, letters, Mid(subjectCell, i, 1), vbTextCompare) = 0 Then
index = i
Exit For
End If
Next i
Range("A1").Value2 = index
End Sub
There are a few problems here
No end if for your if statement
Your cell should be range if you're defining a range like A1, cells is for 1, 1 type reference
Using ActiveCell is poor form, define it explicitly
Using Range("A1").Value is better but also poor form, fully define it like workbooks("book1.xlsx").sheets("Sheet1").Range("A1").Value
You cant use the letters.function( type in vba, I've illustrated instr (or in string) to show how this can work to a similar effect.
I've changed your code to better illustrate what it maybe should look like:
Sub g()
Dim subjectCell As String
Dim letters As String
Dim index As Integer
letters = "qwertyuiopasdfghjklçzxcvbnmQWERTYUIOPASDFGHJKLÇZXCVBNM "
'subjectCell = ActiveCell.Value
subjectCell = "a"
For i = 0 To Len(subjectCell) - 1
If InStr(letters, subjectCell) > 0 Then
Debug.Print "Found it! It starts at position: " & InStr(letters, subjectCell)
Else
Debug.Print "No Match"
index = i
End If
Next i
Range("A1").Value = index
End Sub
Related
example2 example1 The file name I'm trying to match is on Row A and I'm looking through Row I to see if there is a match I found this code I can't recall where but I am trying to match row of part numbers to a row of its image file names. This code works, however, there is a problem when I run it it takes really long to calculate even just 1 column and when I do hundreds at a time my excel just stops responding, and I have thousands of products I need to match. I am really new with VBA so I can't even figure out the problem.
Please help, thank you.
'Name function and arguments
Function SearchChars(lookup_value As String, tbl_array As Range) As String
'Declare variables and types
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
'Iterste through each cell
For Each cell In tbl_array
'Save cell value to variable
str = cell
'Iterate through characters
For i = 1 To Len(lookup_value)
'Same character?
If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
'Add 1 to number in array
a = a + 1
'Remove evaluated character from cell and contine with remaning characters
cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
End If
'Next character
Next i
a = a - Len(cell)
'Save value if there are more matching characters than before
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
'Return value with the most matching characters
SearchChars = Value
End Function
EDIT (post seeing the data): The following should be notably faster (as well as notably simpler)
'Name function and arguments
Function SearchChars(lookup_value As String, tbl_array As Range) As String
'Declare variables and types
Dim inLenMatched%, vnVal, varLookupValues()
'Puts lookup cell values into a array (to speed things up)
varLookupValues = tbl_array.Value
'Iterate through each lookup value
For Each vnVal In varLookupValues
'Ignore empty cells
If vnVal <> "" Then
'Does part number appear in filename?
If InStr(lookup_value, vnVal) > 0 Then
'Is this match the most complete match so far?
If Len(vnVal) > inLenMatched Then
inLenMatched = Len(vnVal)
SearchChars = vnVal
End If
End If
End If
Next vnVal
'Return match value (or 'No Match' if not matched)
If SearchChars = "" Then SearchChars = "No Match"
End Function
The above is just one off-the-cuff approach.
There are other (and quite possible faster) ways to approach this.
The most obvious step (regardless of method) to improving performance would be to limit tbl_array to only the rows with data (not the entire column).
Separately: Without knowing all possible cases, it's impossible to say for sure. But, in all probability, this can be done with Native excel functions, and (if so) that will deliver the best performance.
As said, minimizing the interactions with the sheet by assigning the range to an array will structurally make your macros faster.
Not tested but these minor changes in your code should help you on the right track:
Option Explicit
'Name function and arguments
Function SearchChars2(lookup_value As String, tbl_array As Range) As String
'Declare variables and types
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
'Iterste through each cell => replace with array
'adapt to correct sheet
Dim arr
arr = tbl_array
For Each cell In arr 'tbl_array
'Save cell value to variable
str = cell
'Iterate through characters
For i = 1 To Len(lookup_value)
'Same character?
If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
'Add 1 to number in array
a = a + 1
'Remove evaluated character from cell and contine with remaning characters
cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
End If
'Next character
Next i
a = a - Len(cell)
'Save value if there are more matching characters than before
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
'Return value with the most matching characters
SearchChars2 = Value
End Function
I was trying to modify your existing code, but I found it easier to just rewrite it using what I consider to be a better structure. And After running the code over 26 columns & 432 rows, It only took 0.2 seconds to find the Closest Matching String.
I moved every value into an array.
I converted the lookup_value and the "cell values" into an array of bytes.
I compared the byte arrays to count matching "characters".
And then I return the string that had the highest number of matching "characters".
Sub Example()
Dim StartTime As Double
StartTime = Timer * 1000
Debug.Print SearchChars3("Toddleson", Range("A1:Z432"))
Debug.Print "Time Elapsed: " & Timer * 1000 - StartTime & " ms"
'Time Elapsed: 171.875 ms
End Sub
Function SearchChars3(lookup_value As String, tbl_array As Range) As String
Dim ClosestMatch As String, HighestMatchCount As Integer
Dim tbl_values() As Variant
tbl_values = tbl_array.Value
Dim LkUpVal_Bytes() As Byte
LkUpVal_Bytes = ToBytes(lookup_value)
Dim Val As Variant
For Each Val In tbl_values
If Val = "" Then GoTo nextVal
Dim Val_Bytes() As Byte
Val_Bytes = ToBytes(CStr(Val))
Dim MatchCount As Integer
MatchCount = CountMatchingElements(LkUpVal_Bytes, Val_Bytes)
If MatchCount > HighestMatchCount Then
HighestMatchCount = MatchCount
ClosestMatch = Val
End If
nextVal:
Next
SearchChars3 = ClosestMatch
End Function
Function ToBytes(InputStr As String) As Byte()
Dim ByteArr() As Byte
ReDim ByteArr(Len(InputStr) - 1)
Dim i As Long
For i = 0 To Len(InputStr) - 1
ByteArr(i) = AscW(Mid(InputStr, i + 1, 1))
Next
ToBytes = ByteArr
End Function
Function CountMatchingElements(Arr1 As Variant, Arr2 As Variant) As Integer
'As elements from Arr1 are found in Arr2, those elements are removed from Arr2, to prevent re-matching with the same elements
'To enable this feature, Arr2 is turned into a Collection
Dim Col2 As New Collection
Dim v As Variant
For Each v In Arr2
Col2.Add v
Next
Dim MatchCount As Integer, i As Long
For Each v In Arr1
For i = 1 To Col2.Count
If Col2.Item(i) = v Then
MatchCount = MatchCount + 1
Col2.Remove (i)
Exit For
End If
Next
Next
CountMatchingElements = MatchCount
End Function
A further optimization could be to have a second version of the ToBytes function that directly outputs the values into a Collection. Then, you can change CountMatchingElements to accept a collection and it wont need to convert the second array into a collection.
I will leave that as an idea for you to experiment with.
Dear experts in Excel and VBA!
Could you tell me how you can color a certain line (condition - the presence of a certain word) in a Comments?
Comment consists of several lines, separated by Chr (10).
Example in picture1:
the comment has 4 lines, the second line contains the word "VBA", so this line should be highlighted in red.
The main problem is that the test word "VBA" can be in any line, there can be from 1 to 10+ lines.
I assumed that:
can move data from comment to cell
replace Chr (10) with some character, for example, "_"
distribute the text of the cell into columns through the "column distribution wizard"
search for the desired word "VBA" in the received cells
determine the cell number and understand that this is the number of the required line in the comment
based on the cell number, paint over the line number in the comment
Can you please tell me if my action logic is correct? Am I heading in the right direction?
If so, what is the correct way to carry out points 4-6?
enter image description here
would this help?
"test" is the codename for the sheet I have set, change it according to your situation.
"i" will give you the line number, starting from 0. So in your example it would be 1.
Edit: Added Exit For in the if check.
Option Explicit
Sub test_note()
Dim strNote As String
Dim arrNote As Variant
Dim number_of_lines As Integer
strNote = test.Range("A5").NoteText
number_of_lines = Len(strNote) - Len(Replace(strNote, Chr(10), "")) + 1
ReDim arrNote(1 To number_of_lines) As String
arrNote = Split(strNote, Chr(10))
Dim i As Long
For i = LBound(arrNote) To UBound(arrNote)
If InStr(arrNote(i), "VBA") > 0 Then
Debug.Print i, arrNote(i)
Exit For 'If you are sure there won't be any other occurrence of VBA in there, why check the rest of the lines? Speeds code depending on circumstance.
End If
Next i
End Sub
Edit 2: Revised code to change the color of the comment line.
Sub test_note()
Dim strNote As String
Dim arrNote As Variant
Dim number_of_lines As Integer
strNote = test.Range("B5").NoteText
number_of_lines = Len(strNote) - Len(Replace(strNote, Chr(10), "")) + 1
ReDim arrNote(1 To number_of_lines) As String
arrNote = Split(strNote, Chr(10))
Dim i As Long
Dim startPos As Integer
Dim number_of_chars As Integer
startPos = 1
' Reset comment font color
test.Range("B5").Comment.Shape.TextFrame.Characters.Font.Color = 0
For i = LBound(arrNote) To UBound(arrNote)
If InStr(arrNote(i), "VBA") > 0 Then
number_of_chars = Len(arrNote(i))
test.Range("B5").Comment.Shape.TextFrame.Characters(startPos, number_of_chars).Font.Color = vbRed
Debug.Print i, arrNote(i), "startPos: " & startPos, "numChars: " & number_of_chars
Else
startPos = startPos + Len(arrNote(i)) + 1
End If
Next i
End Sub
Check this. Just running this VBA copies your comments to the cells
and highlights the lines containing "VBA", however, it does this for
all comments on all sheets
credit: https://martinbosanacvba.blogspot.com/2021/08/copying-comments-to-cells-and.html
Sub Demo()
Dim tnahqb1 As Range
Dim tnahqb2 As Range
Dim tnahqb3 As Workbook
Dim tnahqb4 As Worksheet
Dim tnahqb5 As Variant
Dim tnahqb6 As Integer
Dim tnahqb7 As Integer
Dim tnahqb8 As Integer
Dim tnahqb9 As Integer
For Each tnahqb10 In ActiveWorkbook.Worksheets
Set tnahqb1 = tnahqb10.Cells.SpecialCells(xlCellTypeComments)
If tnahqb1 Is Nothing Then
MsgBox "No comments in the sheet"
Else
For Each cell In tnahqb1
cell.Value = cell.Comment.Text
tnahqb5 = Split(cell.Comment.Text, Chr(10))
tnahqb6 = UBound(tnahqb5) - LBound(tnahqb5) + 1
For I = LBound(tnahqb5) To UBound(tnahqb5)
If InStr(tnahqb5(I), "VBA") > 0 Then
tnahqb8 = Len(tnahqb5(I))
With cell
tnahqb7 = InStr(cell.Comment.Text, tnahqb5(I))
tnahqb9 = tnahqb7 + tnahqb8
.Characters(tnahqb7, tnahqb8).Font.Color = vbRed
End With
End If
Next I
Next cell
End If
Next tnahqb10
End Sub
I've got the following:
Dim dupArray As Variant
dupArray = Array("dup")
For j = LBound(numArray) To UBound(numArray)
If IsInArray(Range(numArray(j)).Text, dupArray) Then
Range(numArray(j)).Interior.ColorIndex = 3
MsgBox "Duplicate value"
ElseIf IsInArray(Range(numArray(j)).Text, keyArray) Then
Application.OnKey Range(numArray(j)).Text, comArray(j)
ReDim Preserve dupArray(j)
Dim cellEntry As String
cellEntry = Range(numArray(j)).Text
MsgBox cellEntry
dupArray(j) = cellEntry
Else
Range(numArray(j)).Interior.ColorIndex = 3
MsgBox "Unrecognized key code in " & numArray(j)
End If
Next j
In essence, I want VBA to read the contents of a cell and append them to an array for comparison. Code to read the contents of a cell is Range(numArray(j)).Text... For some reason, cellEntry and dupArray(j) are not equal. More specifically, for the cell A6, cellEntry is "b" (which is the correct contents), but dupArray(j) is "A6"... any thoughts? There's no error code, it's just not putting the correct value in the array.
Thank you!
(Edit) Code for Function IsInArray:
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
(Edit 2) Don't pay attention to much else... I'm just wondering why cellEntry doesn't match dupArray(j) for all values of j when they should clearly be the same thing.
Your code seems to work, but it depends on keyArray being populated.
I've run this demo code, including populating numArray and keyArray with test values, to illustrate what happens.
If how I've populated these arrays doesn't match your code, please add that info to your Q.
Sub Demo()
Dim dupArray As Variant
Dim numArray As Variant
Dim keyArray As Variant
Dim comArray As Variant
Dim j As Long
' for testing
numArray = Application.Transpose([A1:A6].Value)
ReDim keyArray(1 To 3)
keyArray(1) = "x"
keyArray(2) = "a"
keyArray(3) = "s"
dupArray = Array("dup")
For j = LBound(numArray) To UBound(numArray)
If IsInArray(Range(numArray(j)).Text, dupArray) Then
Range(numArray(j)).Interior.ColorIndex = 3
'MsgBox "Duplicate value"
ElseIf IsInArray(Range(numArray(j)).Text, keyArray) Then
'Application.OnKey Range(numArray(j)).Text, comArray(j)
ReDim Preserve dupArray(j)
Dim cellEntry As String
cellEntry = Range(numArray(j)).Text
'MsgBox cellEntry
dupArray(j) = cellEntry
Else
Range(numArray(j)).Interior.ColorIndex = 4 ' changed to be distinct for testing
'MsgBox "Unrecognized key code in " & numArray(j)
End If
Next j
End Sub
Sheet, before
Sheet, after
Variable values at end of execution
As you can see, dupArray has been populated sparsley, in line with numArray. This is fine for how it's used with IsInArray. If it's used for something else too, you can change how it's populated.
Is it possible to combine a string and a variable to create a name of another variable and referencing it in the same go? Like this:
Sub Test()
Dim colorName As String
Dim columnYellow As Long
colorName = "Yellow"
columnYellow = 3
Debug.Print columnYellow '-> prints "3"
Debug.Print "column" & colorName '-> prints "columnYellow" (I would like it to return 3)
End Sub
I would want Debug.Print "column" & colorName to return "3" instead of "columnYellow". Ho can I do that?
Variable identifiers can't be concated, except with CallByName what is limited to objects (you can't call a method from a standard module).
As alternative use an array or a collection. You have to use the collection, where you can have a string as key to a value and strings can be concated.
Sub Test()
Dim ColorNameNr As Collection
Dim colorName As String
Set ColorNameNr = New Collection
ColorNameNr.Add 3, "columnYellow"
colorName = "Yellow"
Debug.Print ColorNameNr.Item("columnYellow") '-> prints "3"
Debug.Print ColorNameNr.Item("column" & colorName) '-> prints "3")
End Sub
Might this code help? Enter either a valid index number or a word for a listed colour.
Function ColIndex(ByVal Arg As Variant) As Variant
' return 0 if not found
' first colour listed has the index #1
Const Cols As String = "Red,Green,Yellow"
Dim Col() As String
Dim i As Integer
Select Case VarType(Arg)
Case vbString
Col = Split(Cols, ",")
For i = UBound(Col) To 0 Step -1
' use VbBinaryCompare for case sensitive comparison
If StrComp(Col(i), Arg, vbTextCompare) = 0 Then Exit For
Next i
If i >= 0 Then ColIndex = i + 1
Case vbInteger, vbLong
On Error Resume Next
ColIndex = Split(Cols, ",")(Arg - 1)
End Select
End Function
Could we use an array?
Sub Test()
Dim colors(0 To 1, 0 To 1) as Variant
colors(0, 1) = "Yellow"
colors(1, 0) = 3
Debug.Print "Column " & colors(1, 0) 'prints column number
Debug.Print "Color " & colors(0, 1) 'prints color name
End Sub
I have 2 codes but only one is working in VBA. I have
Private Sub FINALIZEBTN_Click()
Dim response As VbMsgBoxResult
response = MsgBox("HAVE YOU COMPLETED THE FORM IN FULL?", vbYesNo)
If response = vbYes Then
MsgBox "DO NOT FORGET TO SAVE AND SUBMIT THIS FORM"
Else
If response = vbNo Then
MsgBox "PLEASE REVIEW AND COMPLETE THE FORM IN FULL"
Exit Sub
End If
End If
Dim cell As Range
For Each cell In Range("$A$1:" & Range("$A$1").SpecialCells(xlLastCell).Address)
If Len(cell) > 0 Then cell = UCase(cell)
Next cell
Application.ScreenUpdating = True
End Sub
So on the click you get a yes/no prompt then it forces uppercase throughout the whole sheet.
The only symbols we are allowing are '&' and '-'
I would either like another box to pop up when a special character is entered telling them something like "hey you can't do this" or when a special character is found to remove it and just remove it with nothing. If we could get it to remove and replace the latin letters with the acutes (like for spanish) that would also great. Currently I don't see any changes when I save or run the macros with the code in module 1.
I have the following code in Module 1
Function removeSpecial(sInput As String) As String
Dim sSpecialChars As String
Dim i As Long
sSpecialChars = "\/:*?""<>|$,.`"
For i = 1 To Len(sSpecialChars)
sInput = Replace$(sInput, Mid$(sSpecialChars, i, 1), "")
Next
removeSpecial = sInput
End Function
As others have said, you need to call the removeSpecial.
That said, I would rewrite removeSpecial to specify characters you want to keep, as there are many more special characters than what you have listed in removeSpecial
Other changes
Use SpecialCells xlCellTypeConstants to only loop over cells containing values (removes need to test Len and excludes formulas).
Account for possibility sheet has no constant values
Added substitution of accented characters: you will need to extend the ReplaceFrom and ReplaceWith strings to include all replacements you want (make sure these two strings are the same length)
You may (or may not) want to include other characters in the inclusion, eg space, or other punctuation? If so, add them to the sKeepChars Like pattern (leave the - as the first character inside then []
ALL CAPS messages are ugly!
Function removeSpecial(sInput As String) As String
Dim sKeepChars As String
Dim sClean As String
Dim c As String
Dim i As Long, j As Long
Const ReplaceFrom As String = "AE"
Const ReplaceWith As String = "ÀÊ"
sKeepChars = "[-&A-Z" & ReplaceWith & "]"
For i = 1 To Len(sInput)
c = Mid$(sInput, i, 1)
If c Like sKeepChars Then
j = InStr(ReplaceFrom, c)
If j Then
c = Mid$(ReplaceWith, j, 1)
End If
sClean = sClean & c
End If
Next
removeSpecial = sClean
End Function
Private Sub FINALIZEBTN_Click()
Dim response As VbMsgBoxResult
response = MsgBox("Have you completed the form in full?", vbYesNo)
If response = vbYes Then
MsgBox "Do not forget to save and submit this form"
ElseIf response = vbNo Then
MsgBox "Please review and complete the form in full"
Exit Sub
End If
Application.ScreenUpdating = False
Dim cell As Range
Dim rng As Range
With ActiveSheet
On Error Resume Next
Set rng = .Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rng Is Nothing Then
For Each cell In rng
cell = removeSpecial(UCase(cell))
Next cell
End If
End With
Application.ScreenUpdating = True
End Sub
This should work fine:
Dim MyStr As String
For Each cell In Range("$A$1:" & Range("$A$1").SpecialCells(xlLastCell).Address)
If Len(cell) > 0 Then
MyStr = cell
cell = UCase(removeSpecial(MyStr))
End If
Next cell