How to highlight selected text within excel - excel

I would like to write a VBA function to highlight specific text within an excel cell. Is this possible? I've been googling but it's unclear at this point.
to clarify, I would like to search a specific column for a text value (actually a list of values) and highlight the matched text in say yellow.
Note: this is what I ended up doing:
Sub Colors()
Dim searchString As String
Dim targetString As String
Dim startPos As Integer
searchString = "abc"
targetString = Cells(2, 1).Value
startPos = InStr(targetString, searchString)
If startPos > 0 Then
Cells(2, 1).Characters(startPos, Len(searchString)).Font.Color = vbRed
End If
End Sub

This is the basic principle, I assume that customizing this code is not what you are asking (as no details about this were provided):
Sub Colors()
With Range("A1")
.Value = "Test"
.Characters(2, 2).Font.Color = vbGreen
End With
End Sub
Small description although it speaks quite for itself: the first "2" refers to the first character that needs to be colored, the second "2" refers to the length.

This is only for future readers trying to highlight a specific string pattern inside of cells,
(which is how I had interpreted the question)
You can set the string being searched for in F1 in this example
Sub test4String2color()
Dim strTest As String
Dim strLen As Integer
strTest = Range("F1")
strLen = Len(strTest)
For Each cell In Range("A1:D100")
If InStr(cell, strTest) > 0 Then
cell.Characters(InStr(cell, strTest), strLen).Font.Color = vbRed
End If
Next
End Sub

This is answer is specifically for #t.ztrk who has cities in Col1 and text to search for those cities in column 2. He posted his question over here:
is it possible to find and change color of the text in excel
I borrowed from this code from another solution (sorry if it was not the original):https://stackoverflow.com/a/11676031/8716187
Sub test4String2color()
Dim strTest As String
Dim strLen As Integer
strTest = Range("F1")
strLen = Len(strTest)
For Each cell In Range("A1:D100")
If InStr(cell, strTest) > 0 Then
cell.Characters(InStr(cell, strTest), strLen).Font.Color = vbRed
End If
Next
End Sub
I know this might not be elegant but I punched it out in a few minutes to meet the users need. Sorry in advance if the solutions provided above are (1) more flexible or (2) more efficient. Also sorry for my C++ nested loop habits coming through.
#t.ztrk you can record a macro and just stop it (delete whatever is there) or insert a button control and paste the code there. Not sure what your VB familiarity is. Just be sure to select a cell on the worksheet you want to process before you run the macro (it should run on any sheet and can be made to work on any workbook).
Sub Macro1()
'Searches all text in Column 2 on a Sheet for the string located in Column 1
'If found it highlights that text
Dim ThisWB As Workbook
Dim ThisWS As Worksheet
Dim i As Integer
Dim y As Integer
Dim Col1 As Double
Dim Col2 As Double
Dim Col1_rowSTART As Double
Dim Col1_rowEND As Double
Dim Col2_rowSTART As Double
Dim Col2_rowEND As Double
Dim strTest As String
Dim strLen As Integer
'Set up parameter that we know
Set ThisWB = ActiveWorkbook
Set ThisWS = ActiveSheet
Col1 = 1 'city column
Col2 = 2 'text search column
'Define Starting Row for each column
Col1_rowSTART = 1
Col2_rowSTART = 1
'Define ending row for each column
Col1_rowEND = ThisWS.Cells(ThisWS.Rows.Count, Col1).End(xlUp).Row
Col2_rowEND = ThisWS.Cells(ThisWS.Rows.Count, Col2).End(xlUp).Row
'Could be fancy and see which column is shorter ....
'Won't do that here
For i = Col1_rowSTART To Col1_rowEND
'make a string out of each cell value in Col1
strTest = CStr(ThisWS.Cells(i, Col1))
strLen = Len(strTest)
'Roll thorugh all of Column 2 in search of the target string
For y = Col2_rowSTART To Col2_rowEND
'Check if Col1 string is in Col2 String
If InStr(CStr(ThisWS.Cells(y, Col2)), strTest) > 0 Then
ThisWS.Cells(y, Col2).Characters(InStr(ThisWS.Cells(y, Col2), strTest), strLen).Font.Color = vbRed
End If
Next y
Next i
MsgBox ("City Search Complete!")
End Sub
Here is your testing screenshot.
Cheers - Keep learning and applying.
-WWC

One problem with highlighting text in a cell is that there could be more than one occurrence of the string, so the code should really check to see if there are any more. Here's my solution to that problem:
Sub Colors()
Dim searchTerms As Variant
searchTerms = Array("searchterm1", "searchterm2", "lastsearchterm")
Dim searchString As String
Dim targetString As String
Dim offSet As Integer
Dim colToSearch As Integer
Dim arrayPos, rowNum As Integer
colToSearch = 3
For arrayPos = LBound(searchTerms) To UBound(searchTerms)
For rowNum = 2 To 31124
searchString = Trim(searchTerms(arrayPos))
offSet = 1
Dim x As Integer
targetString = Cells(rowNum, colToSearch).Value
x = HilightString(offSet, searchString, rowNum, colToSearc)
Next rowNum
Next arrayPos
End Sub
Function HilightString(offSet As Integer, searchString As String, rowNum As Integer, ingredCol As Integer) As Integer
Dim x As Integer
Dim newOffset As Integer
Dim targetString As String
' offet starts at 1
targetString = Mid(Cells(rowNum, ingredCol), offSet)
foundPos = InStr(LCase(targetString), searchString)
If foundPos > 0 Then
' the found position will cause a highlight where it was found in the cell starting at the offset - 1
Cells(rowNum, ingredCol).Characters(offSet + foundPos - 1, Len(searchString)).Font.Color = vbRed
' increment the offset to found position + 1 + the length of the search string
newOffset = offSet + foundPos + Len(searchString)
x = HilightString(newOffset, searchString, rowNum, ingredCol)
Else
' if it's not found, come back out of the recursive call stack
Exit Function
End If
End Function

#Jack BeNimble
thanks for the code, used it successfully in 10 mins to highlight all the numbers in a cell. I reorganized it a tad, searching all search terms within a row and cell first and allowed for multiple columns. I found one error, your highlight text didn't like repeats 55, 444, only highlighted the odd repeats in a sequence. Modified one line in Highlight Function
newOffset = offSet + foundPos + Len(searchString) - 1 //added the - 1.
here is my modified code.
Sub NumberColors()
Dim searchTerms As Variant
searchTerms = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ".")
Dim searchString As String
Dim targetString As String
Dim offSet As Integer
Dim colsToSearch As Variant
Dim arrayPos, colIndex, colNum As Integer
Dim rowNum As Integer
colsToSearch = Array(4, 44, 45)
For colIndex = LBound(colsToSearch) To UBound(colsToSearch)
colNum = colsToSearch(colIndex)
For rowNum = 5 To 3000
For arrayPos = LBound(searchTerms) To UBound(searchTerms)
searchString = Trim(searchTerms(arrayPos))
offSet = 1
Dim x As Integer
targetString = Cells(rowNum, colNum).Value
x = HilightString(offSet, searchString, rowNum, colNum)
Next arrayPos
Next rowNum
Next colIndex
End Sub
Function HilightString(offSet As Integer, searchString As String, rowNum As Integer, ingredCol As Integer) As Integer
Dim x As Integer
Dim newOffset As Integer
Dim targetString As String
' offet starts at 1
targetString = Mid(Cells(rowNum, ingredCol), offSet)
foundPos = InStr(LCase(targetString), searchString)
If foundPos > 0 Then
' the found position will cause a highlight where it was found in the cell starting at the offset - 1
Cells(rowNum, ingredCol).Characters(offSet + foundPos - 1, Len(searchString)).Font.Color = vbBlue
' increment the offset to found position + 1 + the length of the search string
newOffset = offSet + foundPos + Len(searchString) - 1
x = HilightString(newOffset, searchString, rowNum, ingredCol)
Else
' if it's not found, come back out of the recursive call stack
Exit Function
End If
End Function
Thanks Jack BeNimbleand datatoo

You don't need VBA to do this. You can use Conditional Formatting.
Let's say you have a set of values in column E. You want to enter a value in cell B1 and highlight the cells in column E that match that value.
Highlight the cells in column E and apply the following conditional formatting:
Change the color(s) to suit. This will apply relative conditional formatting to the cells in column E. Ex: select E3 and view the conditional formatting, it should look like this:
You can see how the formula adjusted itself.
(Edit: If you want to match the value in B1 to a substring of a value in column E, use this conditional formatting formula instead: =FIND($B$1,E1)>0)
Now type different values in cell B1. If you type a value that matches one of the values in column E, those cells (in column E) will change color. Change cell B1 to a value that does not exist in column E, the formatting disappears.

Related

How to color a specific line (condition is present) of a comment in Excel?

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

Macro generated by maximum of absolute value of cells

Numeric data is streamed into cells B8, B10, B12, B14, B16 and B18 (see below).
Cell B23 is the maximum of the absolute value of the above cells at any time, so the formula in B23 is :
=MAX(ABS($B$8),ABS($B$10),ABS($B$12),ABS($B$14),ABS($B$16),ABS($B$18))
Cell B5 is a user-defined constant, in our case 13.00, and is the threshold value that will trigger one of the macros.
So, in the case below, B23 = 8.00, and because 8.00 < 13.00 no macro is called.
If, however, B5 was 7.50, then since B23 (8.00) >= 7.50, and B14 is a positive value, Macro_7 is to be called. Had B14 been -8.00, then Macro_8 is to be called.
This process is to be started when the user presses the START button, which has macro START assigned to it. Once a macro is called, the process ends till the user restarts it.
I am having trouble coding this in VBA and would appreciate any assistance.
Please try this function.
Function AbsoluteMaximum(RowNum As Long, _
Sign As Long) As Double
Dim AbsMax As Double ' variables range
Dim Tmp As Double ' temporary value
Dim R As Long ' row number
Dim i As Integer ' loop counter: iterations
R = RowNum
RowNum = 0 ' return 0 in case of failure
For i = 1 To 6 ' number of cells
Tmp = Cells(R, "B").Value
If Abs(Tmp) > AbsMax Then
AbsMax = Abs(Tmp)
Sign = Sgn(Tmp)
RowNum = R
End If
R = R + 2
Next i
AbsoluteMaximum = AbsMax
End Function
It returns 3 values: the absolute maximum, the row number where it was found and its Sign. The Sgn() function returns 1 for a positive number, -1 for a negative number and 0 for zero.
This is how you can call the function from VBA.
Sub Test_AbsMax()
Dim RowNum As Long
Dim Sign As Long
Dim AbsMax As Double
RowNum = 8 ' start row: change to suit
AbsMax = AbsoluteMaximum(RowNum, Sign)
MsgBox "Absolute Max = " & AbsMax & vbCr & _
"Sign = " & Sign & vbCr & _
"in row number " & RowNum
End Sub
You can use the Sign variable with code like
Clm = Iif(Sign < 0, 3, 1), specifying columns A or C to link to a button.
Observe that RowNum is the first row number for your variables when the function is called but changed by the function to become the row number where the maximum was found. Therefore its value is different before and after the function call.
If this number is below the threshold you would call no further macro. Else you would call a macro determined by RowNum and Sign.
Try this
Sub RunMacro()
Dim rng As Range
Dim dThreshold As Double
Dim i As Long
Dim dValue As Double
Dim dRunningMin As Double: dRunningMin = 1E+20
Dim lIndex As Long
' Change the sheet name
With ThisWorkbook.Sheets("Sheet2")
Set rng = .Range("B8:B18")
dThreshold = .Range("B5")
lIndex = 0
For i = 1 To rng.Rows.Count Step 2
dValue = rng.Cells(i, 1).Value
If Abs(dValue) >= dThreshold Then
If Abs(dValue) - dThreshold < dRunningMin Then
dRunningMin = Abs(dValue) - dThreshold
lIndex = i + IIf(dValue < 0, 1, 0)
End If
End If
Next i
If lIndex > 0 Then
Application.Run "Macro_" & lIndex
End If
End With
End Sub
The code above will work out the number whose absolute value is greater than the threshold and is nearest to it.
e.g.
Threshold Macro
13 None
7.5 Macro_7
4 Macro_3 (but not Macro_10)
3.1 Macro_6
3 Macro_11
2 Macro_1
If, however, you want to run all macros for numbers whose absolute values are greater than the threshold then you need something like this:
Sub RunMacros()
Dim rng As Range
Dim dThreshold As Double
Dim i As Long
Dim dValue As Double
' Change the sheet name
With ThisWorkbook.Sheets("Sheet2")
Set rng = .Range("B8:B18")
dThreshold = .Range("B5")
For i = 1 To rng.Rows.Count Step 2
dValue = rng.Cells(i, 1).Value
If Abs(dValue) >= dThreshold Then
Application.Run "Macro_" & i + IIf(dValue < 0, 1, 0)
End If
Next i
End With
End Sub
e.g.
Threshold Macro
13 None
7.5 Macro_7
4 Macro_3, Macro_7 and Macro_10
3.1 Macro_3, Macro_6, Macro_7, Macro_10
3 Macro_3, Macro_6, Macro_7, Macro_10, Macro_11
2 Macro_1, Macro_3, Macro_6, Macro_7, Macro_10, Macro_11

VBA Code to Concatenate strings from column if first integers, or first and third integers, in another column match

Alright, this is a very specific question. I have an excel macro written that takes a web URL, delimits it, transposes it, and then adds adjacent columns that describe the information in the originally transposed columns. Now, I need to add something to my macro that will loop through and check if the first character of one cell matches one of the first 4 characters of another cell. If it does, I need to concatenate strings from the descriptive columns to new cells. I'll illustrate this below:
3,435,201,0.5,%22type%25202%2520diabetes%22,0 Node type 2 diabetes
4,165,97,0.5,%22diet%22,0 Node diet
5,149,248,0.5,%22lack%2520of%2520exercise%22,2 Node lack of exercise
6,289,329,0.5,%22genetics%22,3 Node genetics
7,300,71,0.5,%22blood%2520pressure%2520%22,5 Node blood pressure
7,3,-7,1,0 Arrow +
4,3,-21,1,0 Arrow +
5,3,-22,1,0 Arrow +
6,3,-34,1,0 Arrow +
,7%5D Tail
I added color to make the concept of the problem more easily visualized. In row one of the first column, we see a red 3 that corresponds to 'type 2 diabetes'. In the fifth row of the first column, we see a blue 7 that corresponds to 'blood pressure'. These are both node objects, as the adjacent column signifies. In the sixth cell of the first column we see a blue 7 and a red 3. This indicates that an arrow (also signified by adjacent column) is connecting blood pressure to diabetes. In the next column over, we see an orange plus sign, which indicates this is a positive relationship.
The goal is to populate the next column over with "blood pressure + type diabetes", as I demonstrated in the image. So, I need some code to check the first characters in each node cell, and then compare them to the first 4 characters of each arrow cell. When an arrow that matches two of the nodes is found, I need the code to populate the row next to the + signs with a concatenated string comprised of the names of the nodes pertaining to that arrow, as well as the + sign between them (it's possible that it could also be a minus sign, but one isn't present in this example). Any pointers? I can't wrap my head around this. Edited to add Data
Here is the code of my current macro:
Sub Delimit_Transpose()
Cells.Replace What:="],[", Replacement:="#", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.FormulaR1C1 = "=RIGHT(R[-1]C,LEN(R[-1]C)-36)"
Dim i As Long, strTxt As String
Dim startP As Range
Dim xRg As Range, yRg As Range
On Error Resume Next
Set xRg = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Delimit Transpose", Type:=8)
i = 1
Application.ScreenUpdating = False
For Each yRg In xRg
If i = 1 Then
strTxt = yRg.Text
i = 2
Else
strTxt = strTxt & "," & yRg.Text
End If
Next
Application.ScreenUpdating = True
Set startP = Application.InputBox _
(Prompt:="Paste Range...", _
Title:="Delimit Transpose", Type:=8)
ary = Split(strTxt, "#")
i = 1
Application.ScreenUpdating = False
For Each a In ary
startP(i, 1).Value = Replace(Replace(a, "[", ""), "]", "")
i = i + 1
Next a
i = 1
For Each a In ary
If Len(a) > 13 Then
startP.Offset(i - 1, 1).Value = "Node"
ElseIf Len(a) < 13 And Len(a) > 6 Then
startP.Offset(i - 1, 1).Value = "Arrow"
Else
startP.Offset(i - 1, 1).Value = "Tail"
End If
i = i + 1
Next a
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
i = 1
n = 5
For Each a In ary
openPos = InStr(a, ",%22")
On Error Resume Next
closePos = InStr(a, "%22,")
On Error Resume Next
midBit = Mid(a, openPos + 1, closePos - openPos - 1)
On Error Resume Next
If openPos <> 0 And Len(midBit) > 0 Then
startP.Offset(i - 1, 2).Value = Replace(Replace(midBit, "%22", ""), "%2520", " ")
ElseIf Len(a) < 13 And InStr(a, "-") = 4 Then
startP.Offset(i - 1, 2).Value = "'-"
ElseIf Len(a) < 7 Then
startP.Offset(i - 1, 2).Value = " "
Else
startP.Offset(i - 1, 2).Value = "+"
End If
i = i + 1
n = n + 1
Next a
Application.ScreenUpdating = True
End Sub
This is my approach.
There's room for a lot of improvements, but is a rough code that should get you started.
Read the code's comments and adapt it to fit your needs.
EDIT: I updated the code to match the sample worksheet you uploaded, build the first column range dinamically, validate if commas appear in the first column cell so no error is raised.
As I said in the comments, it's better easier to debug if you call one procedure from the other, instead of merging them.
Code:
Option Explicit
Public Sub StoreConcatenate()
' Basic error handling
On Error GoTo CleanFail
' Define general parameters
Dim targetSheetName As String
targetSheetName = "Test space" ' Sheet holding the data
Dim firstColumnLetter As String
firstColumnLetter = "C" ' First column holding the numbers
Dim firstColumnStartRow As Long
firstColumnStartRow = 7
' With these three parameters we'll build the range address holding the first column dynamically
' Set reference to worksheet
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
' Find last row in column (Modify on what column)
Dim firstColumnlastRow As Long
firstColumnlastRow = targetSheet.Cells(targetSheet.Rows.Count, firstColumnLetter).End(xlUp).Row
' Build range of first column dinamically
Dim firstColumnRange As Range
Set firstColumnRange = targetSheet.Range(firstColumnLetter & firstColumnStartRow & ":" & firstColumnLetter & firstColumnlastRow)
' Loop through first column range cells
Dim valueCell As Range
For Each valueCell In firstColumnRange
' Check if cell contains "," in the second position in string
If InStr(valueCell.Value, ",") = 2 Then
' Store first digit of cell before ","
Dim firstDigit As Integer
firstDigit = Split(valueCell.Value, ",")(0)
' Check if cell contains "," in the fourth position in string
If InStr(3, valueCell.Value, ",") = 4 Then
' Store second digit of cell after ","
Dim secondDigit As Integer
secondDigit = Split(valueCell.Value, ",")(1)
End If
' Store second colum type
Dim secondColumnType As String
secondColumnType = valueCell.Offset(, 1).Value
' Store third column value
Dim thirdColumnValue As String
thirdColumnValue = valueCell.Offset(, 2).Value
' Store nodes values (first digit and second column type)
Select Case secondColumnType
Case "Node"
Dim nodeValues() As Variant
Dim nodeCounter As Long
ReDim Preserve nodeValues(nodeCounter)
nodeValues(nodeCounter) = Array(firstDigit, thirdColumnValue)
nodeCounter = nodeCounter + 1
Case "Arrow"
Dim matchedNodeFirstValue As String
Dim matchedNodeSecondValue As String
matchedNodeFirstValue = IsInArrayReturnItem(firstDigit, nodeValues)(1)
matchedNodeSecondValue = IsInArrayReturnItem(secondDigit, nodeValues)(1)
If matchedNodeFirstValue <> vbNullString And matchedNodeSecondValue <> vbNullString Then
valueCell.Offset(, 3).Value = matchedNodeFirstValue & Space(1) & thirdColumnValue & Space(1) & matchedNodeSecondValue
End If
End Select
End If
Next valueCell
CleanExit:
Exit Sub
CleanFail:
Debug.Print "Something went wrong: " & Err.Description
Resume CleanExit
End Sub
' Credits: https://stackoverflow.com/a/38268261/1521579
Public Function IsInArrayReturnItem(stringToBeFound As Integer, arr As Variant) As Variant
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i)(0) = stringToBeFound Then
IsInArrayReturnItem = arr(i)
Exit Function
End If
Next i
IsInArrayReturnItem = Array(vbNullString, vbNullString)
End Function
Let me know if it works
It appears that you are concatenating the lookups based on the
first and second integers,
where the second column = "Arrow"
If that is the case, I suggest:
Read the data table into a VBA array for faster processing
I am assuming your data is ordered as you show it, with all the Node entries at the start.
if that is not the case, then loop twice -- once to find the Nodes, and second time to concatenate the Arrow data.
Read the diagnoses into a dictionary for fact lookup.
if column2 = "Arrow" then concatenate the lookups of the first and second integers
Write back the data
Note: As written, this will overwrite the original table destroying any formulas that might be there. If needed, you could easily modify it to only overwrite the necessary area.
Note2 Be sure to set a reference (under Tools/References) to Microsoft Scripting Runtime, or change the Dictionary declaration to late-binding.
Regular Module
'set reference to Microsoft Scripting Runtime
Option Explicit
Sub Dx()
Dim WS As Worksheet
Dim rngData As Range, c As Range, vData As Variant
Dim dDx As Dictionary
Dim I As Long, sKey As String, dxKeys As Variant
'Get the data range
Set WS = ThisWorkbook.Worksheets("sheet1")
With WS
'assume table starts in A1 and is three columns wide
Set rngData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
'read into variant array for faster processing
vData = rngData
End With
'create dictionsry for dx lookups
Set dDx = New Dictionary
For I = 2 To UBound(vData, 1)
Select Case vData(I, 2)
Case "Node"
sKey = Split(vData(I, 1), ",")(0) 'first comma-separated number
If dDx.Exists(sKey) Then
MsgBox "duplicate diagnostic key. Please correct the data"
Exit Sub
End If
dDx.Add Key:=sKey, Item:=vData(I, 3)
Case "Arrow"
dxKeys = Split(vData(I, 1), ",")
vData(I, 3) = dDx(dxKeys(0)) & " + " & dDx(dxKeys(1))
End Select
Next I
'reWrite the table
Application.ScreenUpdating = False
rngData = vData
End Sub

Trying to resize a table in the middle of a sheet.

I'm trying to resize a table located in the middle of my sheet. Code snippet - most integers you're seeing are actually variables, but there's no sense in having a huge amount of extra code.
Sub StackOverFlowTest()
destSheet = Thisworkbook.Sheets("Test")
Set DestTb = destSheet.ListObjects("CTROutputTable")
DestTb.Resize DestTb.Range.Resize(100+1,5)
End Sub
I have a table, DestTb, of N rows and 5 columns. I'd like it to turn into 100 rows + a header column. It's located at an unknown (Read: Dynamic) location in my sheet. Moving data into it directly isn't auto-expanding the table, so I need to resize the table first.
How can I easily resize the number of rows in a table?
Full code so far, if you're really interested:
https://gist.github.com/OlivierHJ/5b039a8c5da05d137f5c8d00f6108309
This is an updated answer because OP has a dynamic table. That means the table won't be always in same range, so we need to get the address of ListObject everytime.
For this code, I needed two extra functions to locate the where is the table every time. 1 UDF to extract the text part of an address and 1 UDF to extract the number part of Address.
Sub RESIZZE_TABLE()
Dim DestTb As ListObject
Set DestTb = Sheets("Hoja1").ListObjects("Tabla1")
Dim TotalRows As Long
Dim MyFirstCell As String
Dim MyLastCol As String
Dim MyLastRow As String
Dim ColCount As Integer
ColCount = 5 'number of columns in your table
MyFirstCell = Range(DestTb).Cells(0, 1).Address
TotalRows = (DestTb.DataBodyRange.Count / ColCount) 'how many rows got table
MyLastCol = TextOnly(Range(DestTb).Cells(TotalRows, ColCount).Address) 'we get letter of last column of table
MyLastRow = onlyDigits(Range(DestTb).Cells(TotalRows, ColCount).Address) 'we get number of last row of table
DestTb.Resize Range(MyFirstCell & ":" & MyLastCol & (MyLastRow + 2)) 'change 2 by number of rows you want to increase
End Sub
Private Function TextOnly(ByVal xValue As String) As String
'source: https://www.extendoffice.com/documents/excel/1625-excel-extract-text-from-alphanumeric-string.html
'adapted for SO
Dim OutValue As String
Dim xIndex As Byte
For xIndex = 1 To Len(xValue)
If Not IsNumeric(Mid(xValue, xIndex, 1)) Then
OutValue = OutValue & Mid(xValue, xIndex, 1)
End If
Next
TextOnly = OutValue
End Function
Private Function onlyDigits(s As String) As String
' Variables needed (remember to use "option explicit"). '
Dim retval As String ' This is the return string. '
Dim i As Integer ' Counter for character position. '
' Initialise return string to empty '
retval = ""
' For every character in input string, copy digits to '
' return string. '
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
' Then return the return string. '
onlyDigits = retval
End Function
Tested with a table moving around a worksheet. It did not matter where it was the table, the code always resized the table with no problems.
Hope this works now!
I would imagine that if you are reducing the number of rows you will wish to clear the cells that no longer belong to the table.
Dim iTBLrws As Long, rng As Range, rngOLDBDY As Range
iTBLrws = 100
With Thisworkbook.Sheets("Test").ListObjects("CTROutputTable")
Set rngOLDBDY = .DataBodyRange
.Resize .Range.Cells(1, 1).Resize(iTBLrws, .DataBodyRange.Columns.Count)
If rngOLDBDY.Rows.Count > .DataBodyRange.Rows.Count Then
For Each rng In rngOLDBDY
If Intersect(rng, .DataBodyRange) Is Nothing Then
rng.Clear
End If
Next rng
End If
End With

VBA: Invalid Qualifier

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

Resources