Compare and Copy Code Trouble

T

THRASHER

New member
Joined
Jun 23, 2014
Messages
7
Reaction score
0
Points
0
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 from the example below, 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 that date also and insert the note from sh2. So it should insert a line and copy the note from sh2 after the second 3/28/14 on sh1 and do the same thing after the third 5/30/14 on sh1. I can also share the spreadsheet with the code if that would be more helpful. Any help would be much appreciated.
Code: 
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range, c As Range, fLoc As RangeDim 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


Here is part of sh1:

Conf. DateEntr. DtItem numberItem NameCO NumberCustomer #Rem QtyCustomer Name
3/28/14 3/24/1436A90224MF 500 SS 90-D VITON NDL VALVE0001457521T0010348050SAAB TRADING
3/28/14 3/24/1436A00222MF 250 SS NEEDLE VALVE0001457521T0010348025SAAB TRADING
4/21/14 4/9/14116000611.5"SET OF SOFT CONE PKG000145942071803630LUFKIN MIDDLE EAST - FREE ZONE
Credit Hold
5/22/14 5/20/1429A142693"8V PCSB W/1.5"COMP"G"CONE,HS0001462494718034LUFKIN MIDDLE EAST - FREE ZONE
Credit Hold
5/29/14 5/23/14210501161.12"-1.5"T302 ROD ROT W/ BC2600014638027180325LUFKIN MIDDLE EAST - FREE ZONE
Credit Hold
5/30/14 3/27/14120494015/8"-1"SET OF BUNA-N RAMS(2)0001457885T0010357736NATIONAL DRILLING SERVICES CO, LLC
5/30/14 3/27/14120494021.12" SET OF BUNA-N RAMS (2)0001457885T0010357732NATIONAL DRILLING SERVICES CO, LLC
5/30/14 3/27/14120494031.25" SET OF BUNA-N RAMS (2)0001457885T0010357712NATIONAL DRILLING SERVICES CO, LLC
6/2/14 5/22/14212030061.5"FIGURE 3 HINGE CLAMP000146360371803150LUFKIN MIDDLE EAST - FREE ZONE
Credit Hold


and here is part of sh2:

Conf. DateEntr. DtItem numberItem NameCO NumberCustomer #Rem QtyCustomer Name
3/28/14 3/24/1436A90224MF 500 SS 90-D VITON NDL VALVE0001457521T0010348050SAAB TRADING
3/28/14 3/24/1436A00222MF 250 SS NEEDLE VALVE0001457521T0010348025SAAB TRADING
Credit Hold
4/21/14 4/9/14116000611.5"SET OF SOFT CONE PKG000145942071803630LUFKIN MIDDLE EAST - FREE ZONE
Credit Hold
5/22/14 5/20/1429A142693"8V PCSB W/1.5"COMP"G"CONE,HS0001462494718034LUFKIN MIDDLE EAST - FREE ZONE
Credit Hold
5/29/14 5/23/14210501161.12"-1.5"T302 ROD ROT W/ BC2600014638027180325LUFKIN MIDDLE EAST - FREE ZONE
Credit Hold
5/30/14 3/27/14120494015/8"-1"SET OF BUNA-N RAMS(2)0001457885T0010357736NATIONAL DRILLING SERVICES CO, LLC
5/30/14 3/27/14120494021.12" SET OF BUNA-N RAMS (2)0001457885T0010357732NATIONAL DRILLING SERVICES CO, LLC
5/30/14 3/27/14120494031.25" SET OF BUNA-N RAMS (2)0001457885T0010357712NATIONAL DRILLING SERVICES CO, LLC
Credit Hold
6/2/14 5/22/14212030061.5"FIGURE 3 HINGE CLAMP000146360371803150LUFKIN MIDDLE EAST - FREE ZONE
Credit Hold
 
Why start on row 7 here:
Set rng = sh1.Range("E7:E" & lr)
when the data on both sheets (from your cross post) start in row 2?

It is difficult to work out which sheet is which when you haven't retained their names; could you supply 1 file with both sheets in, properly named and the code you've been trying.
Also, in words, what are you trying to do? (It's difficult to work out what you want to happen from code which isn't doing what it's supposed to do.) I think the code needs a re-write.

Would you be happy working without merged cells? They are a real pain with vba.
 
Yes, this has been posted on other boards. I wasn't getting any replies and thought I had waited long enough to post here. If I did not my apologies. I do not want to step on any toes
 
Yes, this has been posted on other boards. I was not getting any replies and thought I had waited long enough to post here. If I did not, my apologies. I do not want to step on any toes. I am just trying to solve this issue.
 
The code very well could need a rewrite. Attached below is the spreadsheet with the code. Everyday the Back Orders (sh1) changes. That sheet is saved to the BO Save (sh2) with any new notes. I'm wanting the macro to insert a line where needed on sheet "Back Orders", copy the note for that date from sheet "BO Save" and copy it into the newly inserted line on sheet "Back Orders". I need it to do these for each date. Right now with the code I have it will insert and copy on each line that has a single date but if the sheet has multiple rows with the same date it just skips inserting the note on them. Here is the sheet which will show why I am starting on row 7 also.

BTW, thank for the reply and the interest in maybe helping me.

View attachment BO Report.xlsm
 
THRASHER said:
Yes, this has been posted on other boards. I was not getting any replies and thought I had waited long enough to post here. If I did not, my apologies. I do not want to step on any toes. I am just trying to solve this issue.
Click to expand...
The cross posting thing is pretty universal amongst forums etc. Some moderators ban users/lock threads where it happens incorrectly. What most boards want is that you link to all your cross posts and prefereably update each one if/when the problem is solved. ExcelGuru has a page on the topic: http://www.excelguru.ca/content.php?184-A-message-to-forum-cross-posters
 
THRASHER said:
copy the note for that date from sheet "BO Save" and copy it into
Click to expand...
The note is the merged row with red text right?
Does is pertain to the single row above it, or sometimes more than one row above it?
 
Yes the note is the merged row in red text. the note can pertain to a single row or more than one row. It first checks the CO Number in column E and then the Date in Column A to compare the two sheets. If everything matches insert a blank line and copy the note over. In the spreadsheet I uploaded it should put the note from the BO Save sheet under row 9 on the Back Orders sheet because column E and column A match the same columns on the BO Save sheet. Then it will follow the same procedure for the next line and insert and copy under row 10 on the Back Orders sheet because the criteria matches on both sheets. It will follow this process all the way through the sheet. Anything that does not match, it just skips and goes on. I hope I explained that well enough to make sense. Please keep asking. I will get it clear.
Thanks
 
Try the following code in a standard code module:
Code: 
Sub blah()
Set myNotes = Sheets("BO Save").Range("A8:A49").SpecialCells(xlCellTypeConstants, 2)
For Each rw In myNotes.Rows
  Set FoundCONumber = Sheets("Back Orders").Range("E8:E1000").Find(rw.Offset(-1).Cells(1).Offset(, 4).Value, lookat:=xlWhole, Searchdirection:=2, searchformat:=False)
  If Not FoundCONumber Is Nothing Then
    'Application.Goto rw 'debug line
    'Application.Goto FoundCONumber 'debug line
    If rw.Offset(-1).Cells(1).Value = FoundCONumber.Offset(, -4).Value Then
      rw.Copy
      FoundCONumber.Offset(1).EntireRow.Insert Shift:=xlDown
    Else
      Application.Goto rw
      MsgBox "this comment not transferred"
    End If
  Else
    Application.Goto rw.Offset(-1).Cells(1).Offset(, 4)
    MsgBox "selected number not found on destination sheet"
  End If
Next rw
Application.CutCopyMode = False
End Sub
It runs through the note lines on BOSave, looks for the last instance of CO number on BackOrders, checks the date, if the same then it copies the note across below the found CO Number.

It's not robust, it's even flaky. It makes a few assumptions about how the destination sheet is sorted, and doesn't check whether the correct date exists with that CO Number, however, it's a start and you need to confirm that it's doing more or less the right thing.
 
yes, that is working great. One thing I did not mention is the Back Orders sheet or the BO Save sheet is never the same size. both change daily. The spreadsheet I uploaded is just one day. The next day one sheet may have 92 rows and the other 115 rows. The next day one may have 45 rows and the other 37 rows. And so on. Can you write the code where it will find the last row of each sheet, the compare and copy? The format of both sheets stays the same as in the spreadsheet I uploaded. This is a great start. It does exactly what I was asking up to the stopping point. If you can fix it to where it does not matter how many rows are in each sheet it will be perfect. I really do appreciate your help on this p45cal!
 
The number of rows catered for on the Back Orders sheet is nearly 1000 (Sheets("Back Orders").Range("E8:E1000").Find)
but the BO Save sheet could be tweaked to:
Set myNotes = Sheets("BO Save").Range("A8:A1000").SpecialCells(xlCellTypeConstants, 2)
As long as there isn't anything below the table in column A (stuff below A1000 is ignored) that should be OK (and the list is never goes below row 1000).

The SpecialCells(xlCellTypeConstants, 2) is the same as selecting some cells then pressing F5, Special…. choosing Constants and having a tick in only the Text checkbox below that, OK.
 
Oh, yeah, I see. I should have spotted that. Anyway, it seems to be working perfect. I will use it for a few days to make sure but I do not see there being any issues. I greatly appreciate it p45cal. It is exactly what I was looking for.

THRASHER
 
You must log in or register to reply here.
Back
Top