Compare and Copy Code Trouble

[THRASHER69]

Hello,
I am having trouble figuring out how to fix this code and am hoping someone here can help me out. I have the code below to compare sh1 to sh2. The code works fine if my sheet has single rows that meet the criteria. If there is multiple rows that meet the criteria, it will skip over them. I'm not getting any kind of error. The code runs all the way through. It just skips the rows with multiple criteria. Below is the code and parts of each spreadsheet to look at. As you can see in the sample spreadsheets, the notes in red transfer from sh2 to sh1 just fine except for the rows that have the same date more than once in column A. It should insert a row after the last row of the multiple date rows also and insert the note from sh2. I think it is in the part of the code I made red but I do not know how to fix it. Any help would be much appreciated.

Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range, c As Range, fLoc As Range
Dim fAdr As String
Set sh1 = Sheets("Back Orders")
Set sh2 = Sheets("BO Save")
lr = sh1.Cells(Rows.Count, 5).End(xlUp).Row
Set rng = sh1.Range("E7:E" & lr)
    For Each c In rng
        Set fLoc = sh2.Range("E:E").Find(c.Value, , xlValues)
            If Not fLoc Is Nothing Then
                fAdr = fLoc.Address
                Do
                    If Trim(c.Offset(0, -4).Value) = Trim(fLoc.Offset(0, -4).Value) Then
                        If fLoc.Offset(1, 0) = "" And fLoc.Offset(1, -4) <> "" Then
                            c.Offset(1, 0).EntireRow.Insert
                            fLoc.Offset(1, -4).Copy c.Offset(1, -4)
                            c.Offset(1, -4).Columns("A:J").Merge
                        End If
                        Exit Do
                    End If
                    fLoc = sh2.Range("E:E").FindNext(fLoc)
                Loop While fAdr <> fLoc.Address
            End If
    Next

sh1.xlsx

sh2.xlsx

[nathansav]

You are not doing the find properly, you need to find the next one,

so would be something like

do until sh2.Range("E:E").Find(c.Value, , xlValues) is nothing

loop

Then loop through starting your search at the previous find

range("H:h").Find("NATHAN",fAdr.cells(1,1),xlvalues,XlLookAt.xlWhole,xlnext)

I am not in excel at the minute, so cant test.

[THRASHER69]

You are not doing the find properly, you need to find the next one,

so would be something like

do until sh2.Range("E:E").Find(c.Value, , xlValues) is nothing

loop

Then loop through starting your search at the previous find

range("H:h").Find("NATHAN",fAdr.cells(1,1),xlvalues,XlLookAt.xlWhole,xlnext)

I am not in excel at the minute, so cant test.

I'm sorry Nathan but I'm not understanding what you suggested I try. At least not yet. I'm still looking

[stnkynts]

fLoc is a range and needs to be treated properly.

fLoc = sh2.Range("E:E").FindNext(fLoc)

'should be 

Set fLoc = sh2.Range("E:E").FindNext(fLoc)

Also change this:

Loop While fAdr <> fLoc.Address And Not fLoc is Nothing

[THRASHER69]

fLoc is a range and needs to be treated properly.

fLoc = sh2.Range("E:E").FindNext(fLoc)

'should be 

Set fLoc = sh2.Range("E:E").FindNext(fLoc)

Also change this:

Loop While fAdr <> fLoc.Address And Not fLoc is Nothing

I changed the code per your suggestions and am still getting the same result as before. It is skipping any rows that have the date listed more than once

New code:

Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range, c As Range, fLoc As Range
Dim fAdr As String
Set sh1 = Sheets("Back Orders")
Set sh2 = Sheets("BO Save")
lr = sh1.Cells(Rows.Count, 5).End(xlUp).Row
Set rng = sh1.Range("E7:E" & lr)
    For Each c In rng
        Set fLoc = sh2.Range("E:E").Find(c.Value, , xlValues)
            If Not fLoc Is Nothing Then
                fAdr = fLoc.Address
                Do
                    If Trim(c.Offset(0, -4).Value) = Trim(fLoc.Offset(0, -4).Value) Then
                        If fLoc.Offset(1, 0) = "" And fLoc.Offset(1, -4) <> "" Then
                            c.Offset(1, 0).EntireRow.Insert
                            fLoc.Offset(1, -4).Copy c.Offset(1, -4)
                            c.Offset(1, -4).Columns("A:J").Merge
                        End If
                        Exit Do
                    End If
                    Set fLoc = sh2.Range("E:E").FindNext(fLoc)
                Loop While fAdr <> fLoc.Address And Not fLoc Is Nothing
            End If
    Next

[stnkynts]

c.Offset(1, 0).EntireRow.Insert

This line is probably causing you trouble. When looping through a range it is usually best to go from the bottom up if you are going to be adding or deleting rows; otherwise those added or deleted rows will be adversely integrated into the loop.

The insert in conjuction with the merging of the range is probably hangining you up; VBA and merged cells do not work well together. At this point I don't know what to say other than you would probalby need to submit your workbook and have you problem evaluated rather than your solution. At this point I have no interest in doing that for you but others on the forum might.

[THRASHER69]

c.Offset(1, 0).EntireRow.Insert

This line is probably causing you trouble. When looping through a range it is usually best to go from the bottom up if you are going to be adding or deleting rows; otherwise those added or deleted rows will be adversely integrated into the loop.



The insert in conjuction with the merging of the range is probably hangining you up; VBA and merged cells do not work well together. At this point I don't know what to say other than you would probalby need to submit your workbook and have you problem evaluated rather than your solution. At this point I have no interest in doing that for you but others on the forum might.

I have left the merge line out and it does the same thing.

If you don't mind, how would you write the line you believe is causing the trouble? I have been stuck on this for a while and would love to get the issue fixed.