I have this code and I need some help in makeing it not case sensitive. Right now the serch is case sensitive and I have some excel tables that contains data that are both in uppercase and inlowercase.
Thanks
Sub FormatSelection()
Dim cl As Range
Dim SearchText As String
Dim StartPos As Integer
Dim EndPos As Integer
Dim TestPos As Integer
Dim TotalLen As Integer
On Error Resume Next
Application.DisplayAlerts = False
SearchText = Application.InputBox _
(Prompt:="Enter string.", Title:="Which string to format?", Type:=2)
On Error GoTo 0
Application.DisplayAlerts = True
If SearchText = "" Then
Exit Sub
Else
For Each cl In Selection
TotalLen = Len(SearchText)
StartPos = InStr(cl, SearchText)
TestPos = 0
Do While StartPos > TestPos
With cl.Characters(StartPos, TotalLen).Font
.FontStyle = "Bold"
.ColorIndex = 3
End With
EndPos = StartPos + TotalLen
TestPos = TestPos + EndPos
StartPos = InStr(TestPos, cl, SearchText, vbTextCompare)
Loop
Next cl
End If
End Sub
Change this one line
StartPos = InStr(Ucase(cl), Ucase(SearchText))
Related
The below VBA code is to highlight text (Case Sensitive) in cells. May I know how I can edit the VBA code below to become Case Insensitive?
Sub HighlightStrings_CaseSensitive_AllowForeignText_NotExactText()
Dim xHStr As String, xStrTmp As String
Dim xHStrLen As Long, xCount As Long, I As Long
Dim xCell As Range
Dim xArr
On Error Resume Next
xHStr = Application.InputBox("What are the words to highlight:", "Word Higlighter")
If TypeName(xHStr) <> "String" Then Exit Sub
Application.ScreenUpdating = False
For Each xCell In Selection
Dim varWord As Variant
For Each varWord In Split(xHStr, Space$(1))
xHStrLen = Len(varWord)
xArr = Split(xCell.Value, varWord)
xCount = UBound(xArr)
If xCount > 0 Then
xStrTmp = ""
For I = 0 To xCount - 1
xStrTmp = xStrTmp & xArr(I)
xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 39
xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Bold = True
xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Italic = True
xStrTmp = xStrTmp & varWord
Next
End If
Next varWord
Next xCell
Application.ScreenUpdating = True
End Sub
So... I have this form where people select different controls (We call safety measures controls, these are not content controls) from a listbox and add them to a list. This is in a repeating table. Each control has a heading label (either "engineering" "administrative" or "PPE" that I want to make bold and underlined but I want the options selected in the listboxes to be in normal formatting.
the portion of code that is printing this to the document looks like this:
Set tableSequence = ActiveDocument.Tables(1)
Set NewRow = tableSequence.Rows.Add
NewRow.Cells(5).Range.Text = "Engineering: " & MyString3 _
& vbCrLf & "Administrative: " _
& MyString4 & vbCrLf _
& "PPE: " & MyString5
I want the words Engineering, Administrative, and PPE to be bold and underlined, and the items represented by the MyString objects to appear in standard formatting. Thank you.
The string portion is as follows:
Private Sub CommandButton6_Click()
Dim tableSequence As Table
Dim NewRow As Row
Dim MyString5 As String
Dim v As Variant
Dim var3
Dim p As String
Dim M As Long
For var3 = 0 To ListBox7.ListCount - 1
If ListBox7.Selected(var3) = True Then
MyString5 = MyString5 & ListBox7.List(var3)
v = Split(MyString5, ",")
p = ""
For M = LBound(v) To UBound(v)
p = p + v(M)
If M Mod 3 = 2 Then
p = p + vbCr
Else
p = p + ","
End If
Next M
p = Left(p, Len(p) - 1)
Debug.Print p
End If
sorry for leaving that out
How to format a part (or multiple parts) of a Cell's Value in a Word table:
I have to admit i am not very fond of Word VBA, but i stitched this Sub together for you and it works in my test document. Adjust it to your needing.
Option Explicit
Sub asd()
Dim tableSequence As Table
Set tableSequence = ActiveDocument.Tables(1)
Dim NewRow As Row
Set NewRow = tableSequence.Rows.Add
NewRow.Cells(5).Range.Text = "Engineering: asd" & vbCrLf & "Administrative: vvv" & vbCrLf & "test" & vbCrLf & "PPE: blabla"
NewRow.Cells(5).Range.Bold = False
NewRow.Cells(5).Range.Underline = False
Dim keywordArr As Variant
keywordArr = Array("Engineering:", "Administrative:", "PPE:")
Dim keyword As Variant
Dim myRange As Variant
Dim startPos As Integer
Dim endPos As Integer
Dim length As Integer
Dim i As Integer
i = 1
For Each keyword In keywordArr
Do While InStr(1, myRange, keyword) = 0
Set myRange = NewRow.Cells(5).Range.Paragraphs(i).Range
i = i + 1
Loop
startPos = InStr(1, myRange, keyword)
startPos = myRange.Characters(startPos).Start
length = Len(keyword)
endPos = startPos + length
Set myRange = ActiveDocument.Range(startPos, endPos)
With myRange.Font
.Bold = True
.Underline = True
End With
Next keyword
End Sub
Below is a solution for the same thing in Excel:
First off you would have to write the text into the cell just like you already do.
Next would be to find the position of your keywords in the cell's value + the length of your keywords like so
startPos = Instr(1, NewRow.Cells(5), "Engineering:")
length = len("Engineering:")
Then you can set up the Font of the found substring via Range.Characters.Font
NewRow.Cells(5).Characters(startPos, Length).Font.Bold = True
NewRow.Cells(5).Characters(startPos, Length).Font.Underline = True
Now the elegant way would be to have an array of keywords and iterate through them to change the font for all them
Dim keywordArr As Variant
keywordArr = Array("Engineering:", "Administrative:", "PPE:")
Dim keyword As Variant
Dim startPos as Integer
Dim length as Integer
For Each keyword In keywordArr
startPos = InStr(1, NewRow.Cells(5), keyword)
length = Len(keyword)
With NewRow.Cells(5).Characters(startPos, Length).Font
.Bold = True
.Underline = True
End With
Next keyword
Sub AddNameNewSheet1()
Dim wsToCopy As Worksheet, wsNew As Worksheet
Dim Newname As String
Newname = InputBox("Number for new worksheet?")
Set wsToCopy = ThisWorkbook.Sheets("Sheet1")
Set wsNew = ThisWorkbook.Sheets.Add
If Newname <> "" Then
wsNew.Name = Newname
End If
wsToCopy.Cells.Copy wsNew.Cells
Dim cell As Range
Dim bIsNumeric As Boolean
Dim testFormula As String
bIsNumeric = False
For Each cell In wsNew.Range("A1:M40")
If cell.HasFormula() = True Then
If bIsNumeric Then
If testFormula = CStr(cell.Formula) Then
cell.Value = "<"
Else
testFormula = cell.Formula
cell.Value = "F"
End If
Else
testFormula = cell.Formula
cell.Value = "F"
End If
bIsNumeric = True
ElseIf IsNumeric(cell) = True Then
bIsNumeric = False
If Len(cell) > 0 Then
cell.Value = "N"
End If
Else
bIsNumeric = False
cell.Value = "L"
End If
Next cell
End Sub
I want to extract column and row that applied in formula. For example,
if formula is =SUM(A10:F10) then I want both A10 and F10 then I remove that is there any way to find out that.
My actual purpose is finding formula without column and row value.
thanks in advance.
If you want to get A10 and F10 from the formula, you can use this, passing your range to strRange:
Sub Extract_Ranges_From_Formula()
Dim strRange As String
Dim rCell As Range
Dim cellValue As String
Dim openingParen As Integer
Dim closingParen As Integer
Dim colonParam As Integer
Dim FirstValue As String
Dim SecondValue As String
strRange = "C2:C3"
For Each rCell In Range(strRange)
cellValue = rCell.Formula
openingParen = InStr(cellValue, "(")
colonParam = InStr(cellValue, ":")
closingParen = InStr(cellValue, ")")
FirstValue = Mid(cellValue, openingParen + 1, colonParam - openingParen - 1)
SecondValue = Mid(cellValue, colonParam + 1, closingParen - colonParam - 1)
Debug.Print FirstValue
Debug.Print SecondValue
Next rCell
End Sub
It does a Debug.Print of the two returned values.
I am trying to get 2 For loops to increment at the same time but am only able to get it to where one loop increments and after that loop has gone through its complete loop then the 2nd loop increments. I would like for the code to go down the list of both loops at the same time where it goes:
set criteria1 (1) and criteria2 (1) to the rngstart and rngend
then runs the For i = (rngStart.Row + 2) To (rngEnd.Row - 3) section and outputs to a text file
then set criteria1 (2) and criteria2 (2) to the rngstart and rngend
then runs the For i = (rngStart.Row + 2) To (rngEnd.Row - 3) section and outputs to a text file
etc.
Any guidance on what I am doing wrong and how to resolve the issue would be greatly appreciated.
Below is the code I am trying to resolve the issue with:
Sub ExportStuffToText()
Dim rngFind As Range, rngStart As Range, rngEnd As Range, rngPrint As Range, cell As Range
Dim Criteria1, Criteria2
Dim sTextPath
Dim strCriteria1() As String
Dim strCriteria2() As String
Dim a As Integer, b As Integer, i As Integer, j As Integer
Dim intCriteria1Max As Integer
Dim intCriteria2Max As Integer
Dim FileNum As Integer
Dim str_text As String
Dim sLine As String
Dim sType As String
Set rngFind = Columns("B")
intCriteria1Max = 5
ReDim strCriteria1(1 To intCriteria1Max)
strCriteria1(1) = "Entry1"
strCriteria1(2) = "Entry2"
strCriteria1(3) = "Entry3"
strCriteria1(4) = "Entry4"
strCriteria1(5) = "Entry5"
intCriteria2Max = 5
ReDim strCriteria2(1 To intCriteria2Max)
strCriteria2(1) = "Entry2"
strCriteria2(2) = "Entry3"
strCriteria2(3) = "Entry4"
strCriteria2(4) = "Entry5"
strCriteria2(5) = "Entry6"
For a = 1 To intCriteria1Max
For b = 1 To intCriteria2Max
Criteria1 = strCriteria1(a)
Set rngStart = rngFind.Find(What:=Criteria1, LookIn:=xlValues)
sTextPath = rngStart
Criteria2 = strCriteria2(b)
Set rngEnd = rngFind.Find(What:=Criteria2, LookIn:=xlValues)
If rngStart Is Nothing Then
MsgBox "Criteria1 not found"
Exit Sub
ElseIf rngEnd Is Nothing Then
MsgBox "Criteria2 not found"
Exit Sub
End If
FileNum = FreeFile
str_text = ""
For i = (rngStart.Row + 2) To (rngEnd.Row - 3)
sLine = ""
sType = Sheets![Sheetnamegoeshere].Cells(i, 8).Text
If sType = "somestring" Or sType = "adifferentstring" Then
For j = 1 To 2
If j > 1 Then
sLine = sLine & vbTab
End If
sLine = sLine & Sheets![Sheetnamegoeshere].Cells(i, j).Text
Next j
If Not Len(Trim(Replace(sLine, vbTab, ""))) = 0 Then
If i > 4 Then
str_text = str_text & IIf(str_text = "", "", vbNewLine) & sLine
End If
End If
End If
Next
Open sTextPath For Append As #FileNum
Print #FileNum, str_text
Close #FileNum
str_text = ""
Next b
Next a
End Sub
Ok I made some modifications in the code. I should be working but I did not test it. Give it a try.
Note that I split the original procedure into three smaller ones. Usually if you have a huge amount of variables on the top, it's a sign that the procedure is too large.
Option Explicit
Sub ExportStuffToText()
Dim shToWork As Worksheet
Dim arrCriteria(4, 1) As String
Dim strText As String
Dim rngFind As Range
Dim rngStart As Range
Dim rngEnd As Range
' Add the criterias pairs
arrCriteria(0, 0) = "Entry1"
arrCriteria(0, 1) = "Entry2"
arrCriteria(1, 0) = "Entry2"
arrCriteria(1, 1) = "Entry3"
arrCriteria(2, 0) = "Entry3"
arrCriteria(2, 1) = "Entry4"
arrCriteria(3, 0) = "Entry4"
arrCriteria(3, 1) = "Entry5"
arrCriteria(3, 0) = "Entry5"
arrCriteria(3, 1) = "Entry6"
' Put the name of the sheet here "Sheetnamegoeshere"
Set shToWork = Sheets("Sheetnamegoeshere")
Set rngFind = shToWork.Columns("B")
Dim t As Long
' Loop through my criteria pairs.
For t = LBound(arrCriteria, 1) To UBound(arrCriteria, 1)
'Try to find the values pair.
Set rngStart = rngFind.Find(what:=arrCriteria(t, 0), LookIn:=xlValues)
Set rngEnd = rngFind.Find(what:=arrCriteria(t, 1), LookIn:=xlValues)
If Not rngStart Is Nothing And Not rngEnd Is Nothing Then
' Create the text to append.
strText = GetStringToAppend(rngStart, rngEnd)
'Write to the file
WriteToFile rngStart.Value, strText
Else
' If one or more of the ranges is nothing then
' show a message.
If rngStart Is Nothing Then
MsgBox "Criteria1 not found"
Exit Sub
ElseIf rngEnd Is Nothing Then
MsgBox "Criteria2 not found"
Exit Sub
End If
End If
Next t
End Sub
'Creates a string that will be append to the file.
Function GetStringToAppend(ByRef rStart As Range, _
ByRef rEnd As Range) As String
Dim sh As Worksheet
Dim sLine As String
Dim sType As String
Dim ret As String
Dim i As Long, j As Long
'Grab the sheet from one of the ranges.
Set sh = rStart.Parent
For i = (rStart.Row + 2) To (rEnd.Row - 3)
sType = sh.Cells(i, 8).Text
If sType = "somestring" Or sType = "adifferentstring" Then
For j = 1 To 2
If j > 1 Then
sLine = sLine & vbTab
End If
sLine = sLine & sh.Cells(i, j).Text
Next j
If Not Len(Trim$(Replace(sLine, vbTab, vbNullString))) = 0 Then
If i > 4 Then
ret = ret & IIf(ret = vbNullString, vbNullString, vbNewLine) & sLine
End If
End If
End If
Next
'Return the value
GetStringToAppend = ret
End Function
'Procedure to write to the file.
Sub WriteToFile(ByVal strFilePath As String, _
ByVal strContent As String)
Dim FileNum As Integer
FileNum = FreeFile
Open strFilePath For Append As #FileNum
Print #FileNum, strContent
Close #FileNum
End Sub
I hope this helps :)
I wrote the following code in order to ask for an input.
validInput = False
Do
str = InputBox("Some text...")
If str = vbNullString Then
MsgBox ("Input canceled")
Exit Sub
Else
If IsNumeric(str) Then
exchange = CCur(str)
validInput = True
Else
MsgBox ("Input invalid.")
End If
End If
Loop Until validInput
However, if I cancel my input it keeps asking me for an input and the loop goes on even though I added the Exit Sub line.
I tried to add validInput = True before Exit Sub but that didn't work either.
What am I missing?
EDIT:
Here is the whole sub.
Public Sub CurrencyCheck()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Datenbank")
Dim lastRow As Long
lastRow = ws.Cells(Rows.Count, 4).End(xlUp).Row
Dim i As Long
Dim j As Long
Dim curSymbol As String
Dim exchange As Currency
Dim str As String
Dim curArr() As String
Dim arrCnt As Integer
arrCnt = 1
Dim curInArr As Boolean
curInArr = False
Dim curIndex As Integer
Dim validInput As Boolean
ReDim curArr(1 To 2, 1 To arrCnt)
For i = 1 To lastRow
If ws.Cells(i, 4).Value <> "Price" And ws.Cells(i, 4).Value <> "" Then
curSymbol = Get_Currency(ws.Cells(i, 4).text) 'Function that returns currency symbol (€) or abbreviation (EUR)
If curSymbol <> "€" Then
For j = LBound(curArr, 2) To UBound(curArr, 2)
If curArr(1, j) = curSymbol Then
curInArr = True
curIndex = j
End If
Next j
If Not curInArr Then
If curSymbol = "EUR" Then
ReDim Preserve curArr(1 To 2, 1 To arrCnt)
curArr(1, arrCnt) = curSymbol
curArr(2, arrCnt) = 1
curIndex = arrCnt
arrCnt = arrCnt + 1
Else
validInput = False
Do Until validInput
str = InputBox("Some text...")
If str = vbNullString Then
MsgBox ("Input canceled.")
Exit Sub
Else
If IsNumeric(str) Then
exchange = CCur(str)
validInput = True
Else
MsgBox ("Input invalid.")
End If
End If
Loop
ReDim Preserve curArr(1 To 2, 1 To arrCnt)
curArr(1, arrCnt) = curSymbol
curArr(2, arrCnt) = exchange
curIndex = arrCnt
arrCnt = arrCnt + 1
End If
End If
ws.Cells(i, 4).Value = StringToCurrency(ws.Cells(i, 4).text)
ws.Cells(i, 4).Value = ws.Cells(i, 4).Value * curArr(2, curIndex)
ws.Cells(i, 4).NumberFormat = "#,##0.00 €"
End If
End If
Next i
End Sub
EDIT2: When I run the input loop as a subroutine by itself it works. The macro is run in another workbook and doing that it fails...
EDIT3: My bad. The problem is not related to the code but to the positioning of the subroutine. It was called of and over again because it was called in a loop. I have to apologize. Thanks to everyone.
This will loop until a numeric is entered:
Sub dural()
Dim validInput As Boolean
Dim strg As String, x As Variant
validInput = False
Do
strg = Application.InputBox(Prompt:="enter value", Type:=2)
If strg = "False" Then
ElseIf IsNumeric(strg) Then
x = CCur(strg)
validInput = True
End If
Loop Until validInput
End Sub
EDIT#1:
This version will quit the loop if the user touches the CANCEL button or the red x button:
Sub dural()
Dim validInput As Boolean
Dim strg As String, x As Variant
validInput = False
Do
strg = Application.InputBox(Prompt:="enter value", Type:=2)
If strg = "False" Or strg = "" Then
validInput = True
ElseIf IsNumeric(strg) Then
x = CCur(strg)
validInput = True
End If
Loop Until validInput
End Sub
I don't think is a null string. Try this
If str = vbNullString or str = "" Then