Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed last year.
Improve this question
I have some .doc files with a lot of text, and I want to change the color of the text each 217 characters. The first 217 characters (including blank spaces) would be one color, the next 217 would be another color and so on.
BUT, I also wanted to create a condition where: If the 217 characters don't end with a period, then the selection must be reduced to the last period before 217.
For example: "The car is blue. We need to go to the". In this case, the sentence: "We need to go to the" would not be selected, because it doesn't end with a period, so the selection would be "the car is blue.", because it does end with a period.
I don't know how can I do this in Word, I'm new to VBA and I don't know if it's possible because I'm used to Excel. Can someone help me?
This code will alternate highlighting yellow and green according to your rules. It may not be perfect, but it will get you started.
Public Sub HighlightText()
Dim lStart As Long, lEnd As Long
Dim r As Range
Dim lColor As Long
lStart = 0
lEnd = 217
lColor = wdBrightGreen
Set r = ThisDocument.Range(lStart, lEnd)
Do Until lEnd > ThisDocument.Range.Characters.Count
'find the last period
r.Find.Execute FindText:=".", Forward:=False
'if found, record where it is
If r.Find.Found Then
lEnd = r.End
Else
Exit Do
End If
'highlight the range
ThisDocument.Range(lStart, lEnd).HighlightColorIndex = lColor
'set up for the next section
lStart = lEnd
lEnd = lEnd + 217
'if you're not at the end, reset r
If lEnd <= ThisDocument.Range.Characters.Count Then
Set r = ThisDocument.Range(lStart, lEnd)
End If
'alternate colors
If lColor = wdBrightGreen Then lColor = wdYellow Else lColor = wdBrightGreen
Loop
ThisDocument.Range(lStart, ThisDocument.Range.Characters.Count).HighlightColorIndex = lColor
End Sub
Related
Trying to make an Acronym list for work. First column list the acronym. Second column spells out the acronym while keeping the main components capitalized.
Ex. | POC | Point Of Contact |
Goal is to format the capitalized characters for easier viewing by making them bold, increasing the size, and changing the color to red.
Ex. | POC | Point Of Contact | ------------imagine letters are red and bigger
Since I have 1,000+ acronyms to deal with I created a VBA code to check each character per cell and format the correct ones. Below you can find my code.
Excel can handle some phrases fine while choking then crashing on others. I've tried to check for patterns as to why without any luck.
Other times Excel will act in unpredictable ways such as duplicating the leading letter or highlighting the rest of the phrase red. When comparing the text value in the formula bar vs what's visible in the cell, one can see a difference
Example of error
These troubled cells have a tendency to corrupt the file if saved and re-opened.
Is there something inherently wrong with my code, or is Excel just being buggy for some reason? Would there be a different way to do this without causing excel to have bugs and corrupt the file?
UPDATE: Another Example of Error Running the suggested code
Sub Acronym_List_Formatting()
Dim cll As Range
Dim i As Long
Dim q As Integer
Dim Char As String
Dim UChar As String
Dim Phrase() As String
q = Application.InputBox("Set the base font size", Default:=12, Type:=1)
'| Set initial formatting of everything |'
With Selection.Font
.Name = "Calibri"
.Size = q
.Bold = False
.Color = vbBlack
End With
'| Main Code |'
For Each cll In Selection
ReDim Phrase(Len(cll.Value))
For i = 1 To Len(cll.Value)
Char = Mid$(cll.Value, i, 1)
UChar = UCase$(Char)
Phrase(i) = Char
If Asc(UChar) >= 65 And Asc(UChar) <= 90 Then '|Asc returns the ASCII value ; Continues only if character is a letter|'
If Char = UChar Then
With cll.Characters(i, 1).Font
.Bold = True
.Size = .Size + 1.5
.Color = vbRed
End With
End If
End If
Next i
'Debug.Print "Phrase: " & Join(Phrase)
MsgBox ("Phrase: " & Join(Phrase, ""))
Next cll
End Sub
UPDATE(2): An excerpt of my data for testing
Amcom[aviation and missile command] Engineering Directorate
c2BmC[command and control, battle management and communication] element lead
Bmds[ballistic missile defense system] Opir[overhead persistent infrared] Architecture
Jtids[joint tactical information distribution system] Interface Control
Nato[north atlantic treaty organization] General Communications System
Osf[objective simulation framework] Public Interface
Patriot[phased array tracking radar intercept on target] Advanced Capability 3 SIMulation
Patriot[phased array tracking radar intercept on target] Anti‐Cruise Missile
Patriot[phased array tracking radar intercept on target] Conduct Of Fire Trainer
RW[] Integrated ToolSet
Sm‐3[standard missile‐3] Cooperative Development
SPAWAR[Space & Naval Warfare Systems Command] Systems Center PACIFIC
THaad[terminal high altitude area defense] element lead
If you only need to identify and format upper case letters you can use this:
Option Explicit
Public Sub AcronymListFormatting()
Dim fntSz As Variant, cll As Range, i As Long, char As String
fntSz = Application.InputBox("Set the base font size", Default:=12, Type:=1)
If fntSz <> False And fntSz > 7 Then 'validate user input and Cancel
Application.ScreenUpdating = False
With Selection.Font
.Name = "Calibri"
.Size = fntSz
.Bold = False
.Color = vbBlack
End With
For Each cll In Selection.Cells
For i = 1 To Len(cll.Value2)
char = Mid$(cll.Value2, i, 1)
If Asc(char) >= 65 And Asc(char) <= 90 Then 'A-Z = 65-90, a-z = 97-122
With cll.Characters(i, 1).Font
.Bold = True
.Size = .Size + 1.5
.Color = vbRed
End With
End If
Next
Next
Application.ScreenUpdating = True
End If
End Sub
To convert to proper case:
cll.Value2 = WorksheetFunction.Proper(cll.Value2)
or
cll.Value2 = StrConv(cll.Value2, vbProperCase)
Edit 1
Testing with new data:
Edit 2
The issues (random errors) were caused by corrupt text imported from external file, as seen in P. McInturff's comment bellow
I want to ask for a letter color in an If conditional:
string="asdfghjkl"
for i=1 to len(string)
letter = mid(string, i, 1)
input_letter = inputbox("Write a letter")
if letter = input_letter 'and letter.Font.Color = RGB(31,78,120)
'my code here
endif
next
The and letter.Font.Color = RGB(31,78,120) is not working. It says i need an object.
Is there any similar way to ask this? This RGB color is blue, and I am using this code to transform the entire sentence to blue (with the record macro excel setting)
With Selection.Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = -0.499984740745262
End With
Thanks
Regarding your question's problem:
The .Font.Color is a property of the class Range, but in your line of code:
if letter = input_letter 'and letter.Font.Color = RGB(31,78,120)
... you're trying to access this property in the variable letter, which is a String (you don't explicitly declare it as such, but it gets automatically declared when you execute letter = mid(string, i, 1) just above).
That is why you get an Object required exception: you're trying to access the property .Font.Color on something that is not a Range object (actually, not an Object at all).
Regarding your real need:
I'm not sure to understand what you're trying to do. Are you trying to reach a multi-colored text into a single cell in Excel? If I've got it right, you'll have a string:
string="asdfghjkl"
(please note: you can't call your variable String, that's a reserved keyword for the code. Think of calling it something else, though I guess you already do that in your real code or you wouldn't be able to execute it at all).
... and, for each letter of that string,
for i=1 to len(string)
... you want the user to give you a color. In that case, you can't do it in Excel. If not that, could you please express better your real need?
The code below comes closest to your OP logic and comment using the .Characters property of a cell Range (B11) containing your string value:
Code
Option Explicit
Sub test()
Dim blue As Long: blue = RGB(31, 78, 120)
Dim s As String: s = "asdfgh"
Dim letter As String
Dim input_letter As String
Dim i As Integer
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("MySheet").Range("B11")
With rng
.Value = s
' color whole string
.Characters(1, Len(s)).Font.Color = blue
For i = 1 To Len(s)
letter = Mid(s, i, 1)
input_letter = InputBox("Write a letter")
If letter = input_letter And .Characters(i, 1).Font.Color = blue Then
'color found character
.Characters(i, 1).Font.Color = vbWhite
ElseIf input_letter = "" Then Exit For
End If
Next
End With
End Sub
Notes
Always use Option Explicitin your modules declaration head. So you would see that String isn't allowed as variable name as it's a function.
The extra color check in the If condition seems redundant, as characters so long a r e blue.
You seem to prefer repeated InputBoxes within the For - Next loop, could be reduced to a single call.
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 8 years ago.
Improve this question
It seemed like a simple code but I couldn't find it anywhere on the net & I don't know how to write it.
What I want to do is that, say, cell range A1 has a value of "Hey ho he ha".
What I want the code to do is to remove away the rest of the word after the 1st space, so what's left will be with only "Hey".
Thanks!
One line Code...
Range("A1").Value = Split(Range("A1").Value, " ")(0)
Another one line code (based on IolandaAB's answer)
If InStr(1, Range("A1").Value, " ") Then Range("A1").Value = Mid(Range("A1").Value, 1, InStr(1, Range("A1").Value, " ") - 1)
And yet another one line code
If InStr(1, Range("A1").Value, " ") Then Range("A1").Value = Left(Range("A1").Value, InStr(1, Range("A1").Value, " ") - 1)
Take your pick :) My favorite is still the first one.
Sub extract()
Dim myString As String, lung As Integer, i As Integer, pos As Integer
myString = Range("A1").value
lung = Len(myString)
For i = 1 To lung
pos = InStr(i, myString, " ")
If pos <> 0 Then
Exit For
End If
Next i
Range("A1").value = Mid(myString, 1, pos)
End Sub
Loop through the value from your cell and exit when the first space is found in your text. Extract the text before the found space and copy this in your cell.
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 9 years ago.
Improve this question
In my program l am using timers to make pictureboxes visible and after certain time l make them not visible by using picturebox(1-9).visible = true/false.
Finally l have to count how many pictureboxes are visible at any given time.
l can't figure it out l have tried adding them to a variable but the timer does it over and over every second. l have literally no idea how to do it
This code is for Images on a worksheet, but can easily be modified for wherever your pictureboxes are:
'Count the visible number before starting.
Dim NumberVisible As Integer
NumberVisible = 0
For i = 1 To 9
If myWorkSheet.Shapes(i).Visible = msoTrue Then
NumberVisible = NumberVisible + 1
End If
Next
'....
'Start timer, do timer code here.
'....
myWorkSheet.Shapes(i).Visible = msoTrue
NumberVisible = NumberVisible + 1
'...
myWorkSheet.Shapes(i).Visible = msoFalse
NumberVisible = NumberVisible - 1
You need to check picturebox(1-9).visible itself. The same variable can be set and can also be checked for a given value.
Just loop through all the picture boxes in the form and check their visible property.
Sub foo()
Dim ct As Control
Dim sum As Integer
sum = 0
For Each ct In Me.Controls
If TypeName(ct) = "Image" Then
If ct.Visible = False Then
sum = sum + 1
End If
End If
Next
MsgBox sum
End Sub
In this case, I want to extract the beginning text in a cell and leave the remainder intact.
e.g. a series of cells contain:
2nd Unit. Miami
3rd Production Staff. Toronto
1st Ad. San Francisco
I want to break this up without using Text to columns as previous rows are formatted differently and these last few rows are outliers that I want to handle.
I thought Regular Expressions might do it, but that seems a bit complex.
My algorithm idea is:
1. grab the wanted text (what function or custom sub would do that?)
2. Past the text to it's new location
3. Cut the text from the cell, leaving the remaining text.
Seems simple but I'm still wending my way through VBA forest, and at the rate I'm going it's going to end up faster doing it by hand. But this seems like a good opportunity to learn some VBA tricks.
TIA
Update:
I want to take the text up to the ".\ " and move it to a different column, keeping the remainder where it is.
VBA is unnecessary. To get the text after .\ in cell A1: =MID(A1,FIND(".\",A1,1)+2,LEN(A1)) to get the text before .\ in A1: =LEFT(A1,FIND(".\",A1,1)-1).
As additional information, Find returns the placement in the string where .\ appears. It is the equivalent of InStr in VBA. If .\ is not in the cell, it will display #VALUE, because I didn't bother to add error checking.
Since you seem to want to modify the cell text in place, VBA will be required.
Inside a loop that sets cl to the cell to be processed:
str = cl.value
i = Instr(str, ".\")
cl = Trim(Mid$(str, i + 2)) ' assuming you want to exclude the ".\"
cl.Offset(0, 1) Trim(Left$(str, i - 1)) ' Places the original first part one cell to the right
For the sake of anyone who had this same question, here is the fully tested, working code.
Function RE6(strData As String) As String
Dim RE As Object, REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "[0-9][0-9][0-9][0-9]B"
RE6 = .test(strData)
End With
Set REMatches = RE.Execute(strData)
If REMatches.Count > 0 Then
RE6 = True
Else
RE6 = False
End If
End Function
Sub territory()
Dim strTest As String, str As String, cl As Range
strTest = ActiveCell.Value
Set cl = ActiveCell
If RE6(strTest) = True Then
str = cl.Value
i = InStr(str, ". ")
cl = Trim(Mid$(str, i + 2))
cl.Offset(0, 1) = Trim(Left(str, i - 1))
cl.Offset(0, 2) = "Instance"
MsgBox RE6(strTest)
End If
End Sub