.Find refuses to find, stuborn child

[bd3161]

hello, first time posting and a new to excel this code fails {marked as bold type}and I don't know why. Used it a hundred times before. There is a lot of mismatch as my attempts to solve have been ongoing for three weeks.. ya desperation. so any help is more than appreciated.


Option Explicit



Sub Singular()
Dim RealRng As Range
Dim Rng As Variant 'stores the single letter a25-45
Dim FindLetter As String
Dim rCell As Range
Dim Fx As Variant 'stores the word
Dim xlRange As Range
Dim xlCell As Range
Dim xlSheet As Worksheet
Dim FNString As Range
Dim Ran As Variant
Dim rag As Range 'Dim count As Integer, myRange As Range
Dim Rage As Range
Dim NewRange As Range
Dim myR As Range
Dim wrng As Variant

Worksheets("Question").Select
'Range("A25").Select




Set RealRng = ActiveSheet.Range("A25:A45")
For Each Rng In RealRng
If Len(Rng) = 1 Then
Application.Goto Rng, True
MsgBox "Activecell single letter(" & ActiveCell.Address & ") = " & ActiveCell.Value
End If 'this is the letter in A column
'Exit For
Next Rng

FindLetter = ActiveCell.Value 'has the single letter value
'SEARCH FOR only LETTER in Row A2
If Trim(FindLetter) <> "" Then
With Sheets("Question").Range("A3:Z3")
Set rCell = .Find(What:=FindLetter, _
After:=.Cells(.Cells.count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlEnd, _
MatchCase:=False)
If Not rCell Is Nothing Then
Application.Goto rCell, True
MsgBox "Activecell sigle letter a2(" & ActiveCell.Address & ") = " & ActiveCell.Value
rCell.Offset(-1, 0).Select ' now D2 base word soon to be
'Set famMem = ActiveCell
MsgBox "Activecell D1 word(" & ActiveCell.Address & ") = " & ActiveCell.Value
If Trim(Right(ActiveCell.Value, 3)) = "IES" Then
ActiveCell.Replace What:="IES", Replacement:="Y", LookAt:=xlPart
ElseIf Right(ActiveCell, 2) = "ES" Then
ActiveCell.Replace What:="ES", Replacement:=" ", LookAt:=xlPart
ElseIf Right(ActiveCell, 2) = "'S" Then
ActiveCell.Replace What:="'S", Replacement:=" ", LookAt:=xlPart
ElseIf Right(ActiveCell, 1) = "S" Then
ActiveCell.Replace What:="S", Replacement:=" ", LookAt:=xlPart
MsgBox "Activecell 1 word(" & ActiveCell.Address & ") = " & ActiveCell.Value
End If
Selection.Replace Chr$(39), "", xlPart
MsgBox "Activecell base word(" & ActiveCell.Address & ") = " & ActiveCell.Value
Set Fx = ActiveCell 'fx = D2 xxxxxx's without the 'S
ActiveCell.Offset(1, 0).Select 'D3 back to the letter
MsgBox "Activecell 1 letter after replace(" & ActiveCell.Address & ") = " & ActiveCell.Value
Set FNString = ActiveCell
'find the letter again in parts of sentence

'SEARCH FOR FIRST LETTER PartsofSentence
If Trim(FNString) <> "" Then
With Sheets("PartsofSentence").Range("A1:Z27")
Set Rng = .Find(What:=FNString, _
After:=.Cells(.Cells.count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
'MsgBox "Nothing found"
End If
End With
End If
MsgBox "Activecell Parts of sentence(" & ActiveCell.Address & ") = " & ActiveCell.Value
Rng = ActiveCell
'SEARCH FOR WORD


'go to the Partsof Sentence sheet and get the value
If Trim(Fx) <> "" Then
With Sheets("PartsofSentence").Range(ActiveCell, ActiveCell.Offset(20, 0))
MsgBox Sheets("PartsofSentence").Range(ActiveCell, ActiveCell.Offset(20, 0)).Address

Set wrng = .Find(What:=Sheets("Question").Range("D2"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not wrng Is Nothing Then
Application.Goto wrng, True
MsgBox "Activecell (" & ActiveCell.Address & ") = " & ActiveCell.Value
Else
MsgBox "Nothing found"
End If
End With
End If
ActiveCell.Select
Selection.Copy
Worksheets("Question").Select



'find single letter

If Trim(FindLetter) <> "" Then
With Sheets("Question").Range("A13:A24")

Set Rage = .Find(What:=FindLetter, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rage Is Nothing Then
Application.Goto Rage, True
ActiveCell.Select
MsgBox "Activecell letter in a16(" & ActiveCell.Address & ") = " & ActiveCell.Value
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
End With

End If


'paste the word and grammer


'ActiveCell.PasteSpecial xlPasteFormats
Application.CutCopyMode = False



ActiveCell.Value = UCase(ActiveCell.Value)

Dim selected_range, selected_range_individual_column() As Range
Dim one_to_how_many_columns, col_count As Long

Set selected_range = Selection
On Error GoTo err_occured:

'-------------------------------------------------------------------------------------
'one_to_how_many_columns value = Number of colums that a single column should be split into
'Provide a sufficiently large value so as to prevent overlaps and overwriting
'-------------------------------------------------------------------------------------
one_to_how_many_columns = 27



Application.DisplayAlerts = False
If Not (TypeName(selected_range) = "Range") Then End
ReDim selected_range_individual_column(selected_range.Columns.count - 1) As Range

For col_count = LBound(selected_range_individual_column) To UBound(selected_range_individual_column)
Set selected_range_individual_column(col_count) = selected_range.Columns(col_count + 1)
'MsgBox "Value = " & selected_range_individual_column(col_count).Cells(1, 1).Value
Next col_count

'Begin Text to Column conversion process by starting from Right and proceeding left
For col_count = UBound(selected_range_individual_column) To LBound(selected_range_individual_column) Step -1

If Application.WorksheetFunction.CountIf(selected_range_individual_column(col_count), "<>") = 0 Then GoTo next_loop:

'-------------------------------------------------------------------------------------
'DataType = xlDelimited or xlFixedWidth
'-------------------------------------------------------------------------------------
'If Data Type = xlDelimited then one has to specify the delimiting characters
' Change the boolean values for various delimiting characters such as :
' ConsecutiveDelimiter, Tab, Semicolon, Comma, Space and Other tokens as per requirement
'If Data Type = xlFixedWidth then one has to specify the widths of the fields using the FieldInfo Array.
' This example specifies three widths for splitting into five columns with each array
' bit containing the cumulative sum of chars till the beginning of each word
' You will have to edit and modify (add more or delete) these values as per need
'-------------------------------------------------------------------------------------

selected_range_individual_column(col_count).TextToColumns _
Destination:=selected_range.Cells(selected_range.row, one_to_how_many_columns * col_count + 1), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, _
Tab:=True, _
Semicolon:=True, _
Comma:=True, _
Space:=True, _
Other:=True, _
OtherChar:=("?"), _
FieldInfo:=Array( _
Array(0, 1), _
Array(3, 1), _
Array(6, 1), _
Array(12, 1), _
Array(17, 1) _
), _
TrailingMinusNumbers:=True
next_loop:
Next col_count
err_occured:
Application.DisplayAlerts = True
End If
End With
End If
'MsgBox "Activecell before copy row(" & ActiveCell.Address & ") = " & ActiveCell.Value
Run "COPYRow"
MsgBox "Activecell after coppyrow(" & ActiveCell.Address & ") = " & ActiveCell.Value
ActiveSheet.Range("A100").End(xlUp).Select
ActiveCell.Select
ActiveCell.Offset(-2, 1).Select
MsgBox "Activecell offset(" & ActiveCell.Address & ") = " & ActiveCell.Value
'Set ReRng = ActiveSheet.Range("A13:A24")
'For Each Rng In RealRng
'If Len(Rng) = 1 Then
If ActiveCell = "NOU" And ActiveCell.Offset(2, 0) = "NOU" Then ActiveCell = "POS1"


MsgBox "Activecell A31sigle letter(" & ActiveCell.Address & ") = " & ActiveCell.Value
'this is the letter in A column
'Exit For
'Next


End Sub

 

[Rick Rothstein]

There is a lot of mismatch as my attempts to solve have been ongoing for three weeks..

    Dim wrng As Variant

    Set wrng = .Find(What:=Sheets("Question").Range("D2"), _
                   LookIn:=xlValues, _
                   LookAt:=xlPart, _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlNext, _
                   MatchCase:=False)[/B]

Too much code to run and test, but in a quick look, I would try either changing the Dim statement for wrng from Variant to Range or, if you want to leave it as Variant, then try removing the Set keyword.

 

[My Aswer Is This]

You should tell us what your attempting to do.
Expecting us to read through all this code and figure out what is wrong without knowing what your attempting to do is a daunting task.

 

[bd3161]

You should tell us what your attempting to do.
Expecting us to read through all this code and figure out what is wrong without knowing what your attempting to do is a daunting task.

Okay, sorry, I will try and sum it up. I get user imput in the form of a question, say What is your mother's name? Then I break it down and match the individual words, using a look up table I find the correct response. When they are broke down and a word that is plural like mother's I chop off the 's and look for the word again. Where this code is failing is the second try at the lookup table going down the column. for some reason it won't find the word.

previously I had wrng set as range, no difference.

 

[My Aswer Is This]

This is beyond my Knowledgebase. Maybe Rick or someone else will be able to help you.

 

[bd3161]

Too much code to run and test, but in a quick look, I would try either changing the Dim statement for wrng from Variant to Range or, if you want to leave it as Variant, then try removing the Set keyword.

Well I think I found the problem or at least one of them. I ran across this website 'http://gregmaxey.mvps.org/word_tip_pages/find_in_defined_bookmark_range.html
Sub FindInBookMarkRangeII()
Dim oRng As Word.Range
Dim i As Long
Set oRng = ActiveDocument.Bookmarks("A").Range
'Collapse the range.
oRng.Collapse wdCollapseStart
With oRng.Find
.Text = "Test"
'Process (count) only instances found in defined search range.
While .Execute And oRng.InRange(ActiveDocument.Bookmarks("A").Range)
i = i + 1
Wend
End With
MsgBox "Found " & i & " time."
i = 0
Set oRng = ActiveDocument.Bookmarks("B").Range
oRng.Collapse wdCollapseStart
With oRng.Find
.Text = "Test"
While .Execute And oRng.InRange(ActiveDocument.Bookmarks("B").Range)
i = i + 1
Wend
End With
MsgBox "Found " & i & " time."
i = 0
Set oRng = ActiveDocument.Bookmarks("C").Range
oRng.Collapse wdCollapseStart
With oRng.Find
.Text = "Test"
While .Execute And oRng.InRange(ActiveDocument.Bookmarks("C").Range)
i = i + 1
Wend
End With
MsgBox "Found " & i & " time."
lbl_Exit:
Exit Sub
End Sub

here is his modified code in vba but written for a word doc. my problem is I can't translate it to excel. Can anybody help.