Loop routine only finds first instance

[ThumbsUp]

This should be easy, but for some reason, this code isn't working properly.

THE SITUATION: Sales occur and are logged by type in one workbook. The user clicks a button control which runs the routine. The routine gathers a SourceID (index key) from the worksheet as well as a SaleType value, opens a second workbook ("Appraisal Master.xlsm"), defines a search range within that workbook, finds the first instance of the SourceID (in column A) and then changes the value on the same row in column J with the updates sales type value. There may be multiple instances of the SourceID in Appraisal Master, so the routine loops to find the next instance until the entire range of data in Appraisal Master has been searched & updated. Appraisal Master is dynamic as additional records are added to it each day so the search range must also be dynamic.

THE PROBLEM: The routine runs fine but will only update the first instance of SourceID in Appraisal Master.

THE CODE:
Sub NoteSalesUpdate()
'
'
Application.ScreenUpdating = False
'
'
curName = ActiveWorkbook.Name
Workbooks(curName).Save
Sheets("Inputs - Note Sales").Select
'
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'
Dim SourceID As String
Dim SaleType As String
SourceID = Sheets("Inputs - Note Sales").Range("G2").Value
SaleType = Sheets("Inputs - Note Sales").Range("Z13").Value
'
Workbooks.Open Filename:="K:\AppraisalMaster.xlsm"
Sheets("Appraisal Data").Select
'
Dim rowCount As Integer
Dim rngSearch As Range
Dim rngFound As Range
Dim LastRow As String
LastRow = Range("A" & Rows.Count).End(xlUp).Row + 1
Set rngSearch = Range("A3:A" & LastRow)
Set rngFound = rngSearch.Find(What:=SourceID, LookIn:=xlValues, LookAt:=xlWhole)
Range("A3:A" & LastRow).Select
For rowCount = 1 To Selection.CurrentRegion.Rows.Count - 1
'
If rngFound Is Nothing Then
MsgBox "Obligor Not found"
Workbooks("AppraisalMaster.xlsm").Save
Workbooks("AppraisalMaster.xlsm").Close
GoTo CalcBack
'
Else
'
Sheets("Appraisal Data").Range("J" & rngFound.Row).Value = SaleType
ActiveCell.Offset(1, 0).Select
End If
'
Next rowCount
'
Application.Calculation = xlCalc
'
Workbooks("AppraisalMaster.xlsm").Save
Workbooks("AppraisalMaster.xlsm").Close
'
' Return to working file
Workbooks(curName).Activate
'
CalcBack:
Application.Calculation = xlCalc
Application.ScreenUpdating = True
'
End Sub

[Bob Phillips]

Can't test it as I have nothing to test it with, but I rewrote it to simpler code, so try this



Sub NoteSalesUpdate()
Dim wbAppraisal As Workbook
Dim SourceID As String
Dim SaleType As String
Dim xlCalc As XlCalculation
Dim rowCount As Long
Dim rngSearch As Range
Dim rngFound As Range
Dim LastRow As Long
Dim NumRows As Long
Dim firstAddress As String

Application.ScreenUpdating = False

curName = ActiveWorkbook.Name
Workbooks(curName).Save
Sheets("Inputs - Note Sales").Select
'
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack

SourceID = Sheets("Inputs - Note Sales").Range("G2").Value
SaleType = Sheets("Inputs - Note Sales").Range("Z13").Value

Set wbAppraisal = Workbooks.Open(Filename:="K:\AppraisalMaster.xlsm")
With wbAppraisal.Worksheets("Appraisal Data")

LastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
Set rngSearch = .Range("A3:A" & LastRow)
Set rngFound = rngSearch.Find(What:=SourceID, LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then

firstAddress = rngFound.Address
Do

.Range("J" & rngFound.Row).Value = SaleType
Set rngFound = .FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <> firstAddress
Else

MsgBox "Obligor Not found"
End If
End With

Application.Calculation = xlCalc

wbAppraisal.Save
wbAppraisal.Close

CalcBack:
Application.Calculation = xlCalc
Application.ScreenUpdating = True
End Sub

[ThumbsUp]

Thanks for the simplification, but, regretably, it yields the same result; only the first instance is updated.

[Bob Phillips]

Post the appraisal workbbok, nothing we can do without it.

[ThumbsUp]

Here you go, names and addresses deleted due to privacy issues.

7628

[Bob Phillips]

Sub NoteSalesUpdate()
Dim wbAppraisal As Workbook
Dim SourceID As String
Dim SaleType As String
Dim xlCalc As XlCalculation
Dim rowCount As Long
Dim rngSearch As Range
Dim rngFound As Range
Dim LastRow As Long
Dim NumRows As Long
Dim firstAddress As String
Dim curName As String

Application.ScreenUpdating = False

curName = ActiveWorkbook.Name
Workbooks(curName).Save
Sheets("Inputs - Note Sales").Select
'
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack

SourceID = Sheets("Inputs - Note Sales").Range("G2").Value
SaleType = Sheets("Inputs - Note Sales").Range("Z13").Value

Set wbAppraisal = Workbooks.Open(Filename:="K:\AppraisalMaster.xlsm")
With wbAppraisal.Worksheets("Appraisal Data")

LastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
Set rngSearch = .Range("A3:A" & LastRow)
Set rngFound = rngSearch.Find(What:=SourceID, LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then

firstAddress = rngFound.Address
Do

.Range("J" & rngFound.Row).Value = SaleType
Set rngFound = rngSearch.FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <> firstAddress
Else

MsgBox "Obligor Not found"
End If
End With

Application.Calculation = xlCalc

wbAppraisal.Save
wbAppraisal.Close

CalcBack:
Application.Calculation = xlCalc
Application.ScreenUpdating = True
End Sub

[ThumbsUp]

That did it. THANKS!

Would you mind explaining the logic failure of my original attempt? It would help me learn.

Thanks again.

Greg

[Bob Phillips]

I am not really sure as the code seemed a little complex to me for a simple Find ... FindNext, that is why I rewrote it. My guess would be that the problem lies in the looping selection of the currentregion, but I cannot say how exactly. Sorry!