I have this routine that works well, but it messes up as it counts paragraph marks. How can I skip paragraph marks?
For Each wrd In ActiveDocument.Words
If Selection.Style = ActiveDocument.Styles("Normal") Then
If wrd.Font.Name <> "Arial" Or wrd.Font.Size < 9 Or wrd.Font.Size = 11 Or wrd.Font.Size > 12 _
Or wrd.Font.Color <> wdColorBlack Or wrd.Font.Color <> wdColorAutomatic Or wdColorBlue Then
wrd.HighlightColorIndex = wdYellow
wordrep = wordrep + 1
End If
End If
Next
Try this
For Each wrd In ActiveDocument.Words
If Selection.Style = ActiveDocument.Styles("Normal") Then
If wrd.Font.Name <> "Arial" Or _
wrd.Font.Size < 9 Or _
wrd.Font.Size = 11 Or _
wrd.Font.Size > 12 _
Or wrd.Font.Color <> wdColorBlack Or _
wrd.Font.Color <> wdColorAutomatic Or _
wrd.Font.Color <> wdColorBlue Then
If Asc(Left(wrd, 1)) <> 13 Then
wrd.HighlightColorIndex = wdYellow
wordrep = wordrep + 1
End If
End If
End If
Next
There's something wrong with your logic. What do you mean by Or wdColorBlue Then? This won't work as intended...
If you mean wrd.Font.Color <> wdColorBlue: The font color can't be both black and blue at the same time, so wrd.Font.Color <> wdColorBlack Or wrd.Font.Color <> wdColorBlue will always be true! Therefore the contents of your inner If construct will always execute.
If you mean wrd.Font.Color = wdColorBlue: When the font is blue, then it is necessarily not black, so the wrd.Font.Color <> wdColorBlack condition is redundant and superfluous.
I don't know whether this addresses your problem... I'm not entirely sure what you mean by "it messes up as it counts paragraph marks".
Related
Looking for either a workaround or some idea on how I can use the code excerpt below, but skip column A.
Basically, I'm using
.EntireRow(a.Row).Interior.Color = color
to highlight rows based on a userform selection, but I need to skip column A as it has headers that have their own highlighting.
Any ideas?
If ToggleButton3.Value = True Then
On Error Resume Next
For iRow = 1 To 15
If Sheets("Prop" & iRow).Visible <> xlSheetVisible Then
Else
With Sheets("Prop" & iRow).Range("$E$1:$E$157")
Set a = .Find(SlctdPAX, LookIn:=xlValues, LookAt:=xlWhole)
.EntireRow(a.Row).Interior.Color = RGB(255, 255, 102) 'yellow
End With
End If
Next iRow
ElseIf ToggleButton1.Value = True Then
On Error Resume Next
For iRow = 1 To 15
If Sheets("Prop" & iRow).Visible <> xlSheetVisible Then
Else
With Sheets("Prop" & iRow).Range("$E$1:$E$157")
Set a = .Find(SlctdPAX, LookIn:=xlValues, LookAt:=xlWhole)
.EntireRow(a.Row).Interior.Color = RGB(255, 0, 0) 'red
End With
End If
Next iRow
ElseIf ToggleButton4.Value = True Then
On Error Resume Next
For iRow = 1 To 15
If Sheets("Prop" & iRow).Visible <> xlSheetVisible Then
Else
With Sheets("Prop" & iRow).Range("$E$1:$E$157")
Set a = .Find(SlctdPAX, LookIn:=xlValues, LookAt:=xlWhole)
.EntireRow(a.Row).Interior.Color = xlNone 'no fill
End With
End If
Next iRow
ElseIf ToggleButton2.Value = True Then
On Error Resume Next
For iRow = 1 To 15
If Sheets("Prop" & iRow).Visible <> xlSheetVisible Then
Else
With Sheets("Prop" & iRow).Range("$E$1:$E$157")
Set a = .Find(SlctdPAX, LookIn:=xlValues, LookAt:=xlWhole)
.EntireRow(a.Row).Interior.Color = RGB(128, 255, 0) 'green
End With
End If
Next iRow
Else
End If
Lets say a is a single cell.
With regards to exclude highlighting column A,
to highlight entire row of a, do:
a.EntireRow.Resize(, Columns.Count - 1).Offset(, 1).Interior.Color
to highlight multiple rows staked together below a, e.g. 5 rows, do:
a.EntireRow.Resize(5, Columns.Count - 1).Offset(, 1).Interior.Color
to highlight multiple rows which are not staked together, e.g. entire rows of [E1], [E3], [E5], do:
Intersect(Union([E1], [E3], [E5]).EntireRow, Cells.Resize(, Columns.Count - 1).Offset(, 1))
FYI, just tested that Union([E1], [E3], [E5]).EntireRow.Resize() is not allowed.
Hope this helps.
With ThisWorkbook.Sheets("Prop" & iRow)
Set a = .Range("$E$1:$E$157").Find(SlctdPAX, LookIn:=xlValues, LookAt:=xlWhole)
a.EntireRow.Resize(1, .Cells(a.row, .Columns.Count - 1).column).Offset(, 1).Interior.Color = RGB(255, 0, 0) 'red
End With
which is quite much whar KS Sheon has already posted.
but I'm afraid his code, being inside With Sheets("Prop" & iRow).Range("$E$1:$E$157") block , would color all rows from 1 to 157.
moreover Columns.Count would count the number of columns of the active sheet, which may not be the one wanted
My VBA script is supposed to split content in one cell by line breaks into several rows, it works for some cells, date in one cell look like this:
a01gestmstrs2a 10.67.15.17
a01gestmdb2a 10.67.15.19
a01gstdbldnim1a
a01rstdbldnim1a
a01gestmstrs2b (10.67.15.46)
a01restmdb2a (10.67.15.48)
a01gestmstrs2z 10.67.15.20
a01gestmdb2b (10.67.15.47)
a01restmstrs2a (10.67.15.49)
However, it fails to split for some such as the sample provided above, I can't figure out why.
My code:
Sub SplitMultipleHostnames()
Dim tmpArr As Variant
Dim s As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each cell In Range("D2", Range("D3").End(xlDown))
For Each c In ActiveSheet.UsedRange
s = c.Value
If Trim(Application.Clean(s)) <> s Then
s = Trim(Application.Clean(s))
c.Value = s
End If
If cell.Value <> "" Then
If InStr(1, cell, Chr(10)) <> 0 Then
tmpArr = Split(cell, Chr(10))
cell.EntireRow.Copy
cell.Offset(1, 0).Resize(UBound(tmpArr), 1).EntireRow.Insert xlShiftDown
cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr)
End If
Else
cell.EntireRow.Delete
cell.Row = cell.Row - 1
End If
Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = False
End Sub
The loop that uses Trim() and Clean() will remove all ASCII 10's and 13's from the worksheet.
There will be nothing to Split().
They are not actually Char(10) they are spaces. I changed the code to " " and it worked fine
If cell.Value <> "" Then
If InStr(1, cell, " ") <> 0 Then
tmpArr = Split(cell, " ")
I have the following for loop on my project:
'Range and Range Array variables
Dim rngArray As Object
Dim rngArrayMain(0 To 9) As Excel.Range
rngArrayMain(0) = xlWSEE.Range("I40")
rngArrayMain(3) = xlWSEE.Range("V46")
rngArrayMain(4) = xlWSEE.Range("L48:N48")
rngArrayMain(5) = xlWSEE.Range("L51")
rngArrayMain(6) = xlWSEE.Range("J35")
rngArrayMain(7) = xlWSEE.Range("J53")
rngArrayMain(1) = xlWSEE.Range("B57:B61")
rngArrayMain(2) = xlWSEE.Range("B70")
rngArrayMain(8) = xlWSEE.Range("L47")
rngArrayMain(9) = xlWSEE.Range("O47")
For Each rngArray In rngArrayMain
With rngArray
.Font.Bold = True
.Font.Size = 10
.Font.Name = "Calibri"
.Font.ColorIndex = 2 'white
End With
Next rngArray
No problem, works well. However, I have to separate the last two elements of my array because the Font.ColorIndex = 1 for them.
So basically my for loop would be:
if array 0-7
perform this action
if array 8-9
then perform this action.
How can I fix my code to reflect this change? If the question seems elementary it's because I have not been programming long and what I know is self-taught (google, bing, and a few books).
Thanks.
Use a For loop instead of a For Each, like this:
For i As Integer = 0 To rngArrayMain.Length - 1
' First seven items do this (index 0 to 6)
If i <= 6 Then
With rngArrayMain(i)
.Font.Bold = True
.Font.Size = 10
.Font.Name = "Calibri"
.Font.ColorIndex = 2 'white
End With
Else
' Last two items do this
With rngArrayMain(i)
.Font.Bold = True
.Font.Size = 10
.Font.Name = "Calibri"
.Font.ColorIndex = 1
End With
End If
Next
Note: If you remove the With block, then you would actually save lines of code, because you put the If logic around the one property that is different, like this:
For i As Integer = 0 To rngArrayMain.Length - 1
rngArrayMain(i).Font.Bold = True
rngArrayMain(i).Font.Size = 10
rngArrayMain(i).Font.Name = "Calibri"
If i <= 6 Then
rngArrayMain(i).Font.ColorIndex = 2
Else
rngArrayMain(i).Font.ColorIndex = 1
End If
Next
Dim cellsWithColor2 As Range
Dim cellsWithColor1 As Range
Dim xlWSEE As Worksheet
Set xlWSEE = Worksheets("FillTheNameHere")
Set cellsWithColor2 = Application.Union( _
xlWSEE.Range("I40"), _
xlWSEE.Range("V46"), _
xlWSEE.Range("L48:N48"), _
xlWSEE.Range("L51"), _
xlWSEE.Range("J35"), _
xlWSEE.Range("J53"), _
xlWSEE.Range("B57:B61"), _
xlWSEE.Range("B70"))
With cellsWithColor2
.Font.Bold = True
.Font.Size = 10
.Font.Name = "Calibri"
.Font.ColorIndex = 2 'white
End With
Set cellsWithColor1 = Application.Union( _
xlWSEE.Range("L47"), _
xlWSEE.Range("O47"))
With cellsWithColor1
.Font.Bold = True
.Font.Size = 10
.Font.Name = "Calibri"
.Font.ColorIndex = 1 'another color
End With
I have a little problem with my macrocode, and need your advice. Here my base macrocode:
Option Explicit
Sub NurZumUeben()
'oberste Zeile löschen, fixieren und linksbündig ausrichten
Rows("1:1").Select
Selection.Delete Shift:=xlUp
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
'Jede zweite Zeile schattieren
Application.ScreenUpdating = False
Dim Zeile, ZeilenNr As Integer
With ActiveSheet.UsedRange.Rows
.Interior.ColorIndex = xlNone
.Borders.ColorIndex = xlNone
End With
ZeilenNr = 2
For Zeile = 2 To ActiveSheet.UsedRange.Rows.Count
With Rows(Zeile)
If .Hidden = False Then
If ZeilenNr Mod 2 = 0 Then
.Interior.ColorIndex = 15
.Borders.Weight = xlThin
.Borders.ColorIndex = 16
ZeilenNr = ZeilenNr + 1
Else
ZeilenNr = ZeilenNr + 1
End If
End If
End With
Next Zeile
Application.ScreenUpdating = True
'oberste Zeile einfärben
Rows("1:1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Spalte_suchen&formatieren
Dim iLeSpa As Integer
Dim iSpalte As Integer
Dim bGefunden As Boolean
iLeSpa = IIf(IsEmpty(Cells(1, Columns.Count)), Cells(1, _
Columns.Count).End(xlToLeft).Column, Columns.Count)
For iSpalte = 1 To iLeSpa
If Cells(1, iSpalte).Value = "click_thru_pct" Then
bGefunden = True
Exit For
End If
Next iSpalte
If bGefunden Then
With Range(Cells(2, iSpalte), Cells(5000, iSpalte))
.Replace What:="%", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows
Range("K1") = 100
Range("K1").Copy
.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide
.NumberFormat = "0.00%"
Range("K1").Clear
End With
Else
MsgBox "Die Überschrift ""click_thru_pct"" wurde nicht gefunden.", _
48, " Hinweis für " & Application.UserName
End If
End Sub
Once thank you all who can help. Unfortunately, I get the final formatting not go quite
Here are the results: example
I did not want to color the entire column but only the top row. In addition, the lower empty fields with ugly 0.00% formatted constantly.
Furthermore, I noticed that after the coloration of the first line, the field K1 is visible. That is with me unfortunately impractical because these Excel documents can also go differently in the row.
Here is the document on which you can test it if necessary.
example
Thank you very much
Change modular function to calculate the for loop variable. I see no purpose in using a separate variable for this. Change this:
ZeilenNr = 2
For Zeile = 2 To ActiveSheet.UsedRange.Rows.Count
With Rows(Zeile)
If .Hidden = False Then
If ZeilenNr Mod 2 = 0 Then
.Interior.ColorIndex = 15
.Borders.Weight = xlThin
.Borders.ColorIndex = 16
ZeilenNr = ZeilenNr + 1
Else
ZeilenNr = ZeilenNr + 1
End If
End If
End With
Next Zeile
To this:
For Zeile = 2 To ActiveSheet.UsedRange.Rows.Count
With Rows(Zeile)
If .Hidden = False Then
If Zeile Mod 2 = 0 Then
.Interior.ColorIndex = 15
.Borders.Weight = xlThin
.Borders.ColorIndex = 16
End If
End If
End With
Next Zeile
I apologize if I am missing something here. Also, I cannot view the examples you provided because the site requires a login and it is not in English. Sorry again.
Within your existing code,
Substitute 5000 with ActiveSheet.UsedRange.Rows.Count
Substitute Range("K1").Clear with Range("K1").ClearContents
Instead of For Zeile = 2 To ActiveSheet.UsedRange.Rows.Count, you could use
For Zeile = 2 To ActiveSheet.Range("A1").CurrentRegion.Rows.Count-1
.UsedRange is not always properly reset. You sample seems a good candidate for .CurrentRegion
In the code below, I take some input parameters, either text or a cell, and combine them to form one string using the formatting I need. I need to make Task_Name bold, as well as text like "Lead :". I know you cannot make text in a variable bold, but how do I go about this? This cell I'm storing the value in is eventually used in a Word mail merge.
I need to format part of a string. In the code below, I need to make Task_Name, "Lead : ", etc. all bold.
Function GENERATE_STAFFING_SECTION(Task_Name, Lead_By, Members, Instructions)
Dim tmpSection As String
If Len(Task_Name > 0) And Len(Lead_By) > 0 And Len(Members) > 0 And Len(Instructions) > 0 Then
tmpSection = vbLf _
& Task_Name _
& vbLf & "Lead : " & Lead_By _
& vbLf & "Ambassadors : " & Members _
& vbLf & "Instructions : " & Instructions _
& vbLf
Else
tmpSection = ""
End If
GENERATE_STAFFING_SECTION = tmpSection
End Function
Also, I know it's not the cleanest code, so if there are any other suggestions for improving it, they are most welcome.
Thanks!
You can't add anything to the string directly to make the cell have bold characters.
Once you've written the string out to the cell, you'll need to go back and reprocess the cell.
For example:
With ActiveCell.Characters(Start:=11, Length:=6).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
This snippet will set only a portion of the cell to bold.
EDIT:
This code could be used to implement the above and give you what you want.
It could be written better, but should give you an idea of what you've got to write:
Public Sub FormatOuput()
Dim i As Integer
'Format Task_name
i = InStr(1, ActiveCell.Text, vbLf)
MakeBold 1, i
'Format 'Lead'
MakeBold i + 1, 4
'Format 'Ambassadors'
i = InStr(i + 1, ActiveCell.Text, vbLf)
MakeBold i+1, 11
'Format 'Instructions'
i = InStr(i + 1, ActiveCell.Text, vbLf)
MakeBold i+1, 10
End Sub
Public Sub MakeBold(startPos As Integer, charCount As Integer)
With ActiveCell.Characters(start:=startPos, length:=charCount).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End Sub