![]() |
#1
|
|||
|
|||
![]()
In the attached xlsm WhyDoesntItFindAct2035 doesn't find the red font in the Act sheet B97. Even if I remove all but the red font from that cell it still won't find it. Any ideas?
|
#2
|
||||
|
||||
![]()
If you look at the captured records, you'll see they all start with something red. If I copy one of those cells to B97, the macro finds it.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
||||
|
||||
![]()
I tried changing to
SrchStr = "?" being a wildcard single character and got some success but it was very unreliable and caused Excel to hang (macro appeared to be running forever) occasionally. So I gave up and resorted to checking each cell character by character. Try this (there are now several unused variables - I'll leave you to clear that up): Code:
Sub WhyDoesntItFindAct2035b() '2/22/2023 'The 1st sheet "Act" contains several verses in the book of Acts that are color formatted. 'I'm trying to find all verses with at least one red letter in them. 'These are the verses with any red letters: 18:9-10 20:35 22:7-8,10,18,21 23:11 26:14-18 'It only finds 18:10 26:16-18 Why? Is there any way to make it find the others using range.find? Dim C As Range, WrkBk As Workbook, Ctr As Long, HitColor As Variant, StRng As String Dim NumOccur As Long, N As Long, StartTime As Double, AdjWrd As String Dim AC As Range, lenACary As Long, cc As Range, ACary() As Variant, chRef As String Dim Ctrstart As Long, Ctrstop As Long, FirstAddress As String Dim BookSht As Worksheet, RsltSht As Worksheet, ByBook As Variant Dim NumCols As Long, M As Long Dim SrchWrd As String Dim SrchColor As Boolean Dim SrchStr As String, MtchCase As Boolean Dim cbOnlyRed As Boolean Dim cll As Range, I MtchCase = False cbOnlyRed = True If MtchCase Then iMtchCase = vbBinaryCompare Else iMtchCase = vbTextCompare End If SrchColor = cbOnlyRed 'False 'True ' NumCols = 7 lenACary = 0 ReDim ACary(NumCols, lenACary) Set WrkBk = ActiveWorkbook Ctrstart = WrkBk.Sheets(1).Index Ctrstop = WrkBk.Sheets(1).Index StRng = "B1" 'start range ByBook = 2 Set RsltSht = WrkBk.Sheets("Results") StartTime = Timer For Ctr = Ctrstart To Ctrstop Set BookSht = WrkBk.Sheets(Ctr) BookSht.Activate Set cc = BookSht.Range(Range(StRng), Range(StRng).End(xlDown)) For Each cll In cc.Cells Set C = Nothing For I = 1 To cll.Characters.Count If cll.Characters(I, 1).Font.Color = RedLetterColor Then Set C = cll Exit For End If Next I If Not C Is Nothing Then chRef = GetRef(BookSht.Cells(C.Row, 1), ByBook) NumOccur = 0 Call UpdateOutputArray(ACary, chRef, lenACary, NumCols, SrchWrd, AdjWrd, NumOccur, ByBook, C) End If Next cll Next Ctr RsltSht.Activate RsltSht.Cells.ClearContents RsltSht.Cells.ClearFormats ACary = TransposeArray(ACary) Set AC = RsltSht.Range(Cells(1, 1), Cells(lenACary + 1, NumCols)) AC.Value = ACary AC.Sort AC.Columns(1), xlAscending, AC.Columns(2), , xlAscending Call VrsFill(AC) AC.Columns(2).ClearContents For N = 1 To AC.Rows.Count - 1 AC.Cells(N, 2) = N Next N TglWrdWrpCol Debug.Print "done WhyDoesntItFindAct2035b " & Format((Timer - StartTime) / 60, "##0.00") & " min. " & Time End Sub |
#4
|
||||
|
||||
![]()
Personally, I'd be inclined to do all this in Word - even automating it from Excel as per the code below if you need the results in Excel. Makes for much simpler code, too:
Code:
Sub GetRedData() 'Note: this code requires a reference to the Word object model. 'See under the VBE's Tools|References. Application.ScreenUpdating = False Dim WkSht1 As Worksheet, WkSht2 As Worksheet, r As Long, x As Long Set WkSht1 = ThisWorkbook.Sheets("Act"): Set WkSht2 = ThisWorkbook.Sheets("Results") Dim wdApp As New Word.Application, wdDoc As Word.Document With wdApp .Visible = False Set wdDoc = .Documents.Add: WkSht1.UsedRange.Copy With wdDoc With .Range .PasteExcelTable False, False, False With .Find .Forward = True .Wrap = wdFindStop .Format = True .Font.Color = 3618778 End With Do While .Find.Execute r = .Cells(1).RowIndex: x = x + 1 With WkSht2 .Range("B" & x).Value = x: .Range("C" & x).Value = r .Range("D" & x).Value = WkSht1.Range("A" & r).Value WkSht1.Range("B" & r).Copy .Paste Destination:=.Range("F" & x) End With .Start = .Cells(1).Range.End + 1 Loop End With .Close SaveChanges:=False End With .Quit End With Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht1 = Nothing: Set WkSht2 = Nothing Application.ScreenUpdating = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
![]() |
Tags |
searchformat |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
jmcsa3 | Excel Programming | 1 | 05-02-2020 06:56 AM |
![]() |
Triadragon | Excel | 3 | 05-02-2016 11:48 AM |
Find a Date in a Range | rspiet | Excel | 3 | 02-15-2016 08:37 AM |
find IP in range / find number between numbers | gn28 | Excel | 4 | 06-14-2015 03:46 PM |
![]() |
Bop70 | Word | 3 | 02-04-2015 11:45 AM |