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.


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!