Help, loop finds overlaps, then adds not overlapped items, but misses the first match
This code builds a list in column S and T from data on 2 other sheets (this workbook)
Then trims down items from T into column Q (not overlapping items only)
T holds all items, S is short some items, I needed 2 separate lists for comparing.
ultimately i build this sheet with all the elements that overlap
then add back the ones that don't to the end.
The script omits the first match every time, not sure what I am missing.:dunno
I can provide sample sheets if needed.
Code:
Sub magicHappens()
Dim oSh, nSh, tSh, ws3 As Worksheet
Dim wb As Workbook
Dim i, x, j, t, nXt As Integer
Dim p, r, oLr, nLr, tLr, aLr, aLr2, qLr, xLr As Long
Dim nCell, nCell2, oCell, tCell, xCell, nRng, oRng, tRng, xRng As Range
Dim nRay, tRay As Variant
Set oSh = Application.Workbooks(1).Sheets("Old")
Set nSh = Application.Workbooks(1).Sheets("New")
Set tSh = Application.Workbooks(1).Sheets("Combined")
tSh.Range("A1:M1").Value = oSh.Range("A1:M1").Value
nSh.Activate ' build list of new order numbers from sheet 2 New
With nSh
nLr = .Cells(.Rows.Count, "C").End(xlUp).Row
r = 1
For i = 1 To nLr
If IsNumeric(.Range("C" & i).Value) And _
.Range("C" & i) <> "" Then
tSh.Range("T" & r).Value = nSh.Range("C" & i).Value
r = r + 1
End If
Next i
End With
aLr = tSh.Cells(tSh.Rows.Count, "T").End(xlUp).Row ' fill array with new order numbers
ReDim nRay(1 To aLr)
For t = 1 To aLr
nRay(t) = tSh.Range("T" & t).Value
Next t
oSh.Activate ' build a list of old orders from sheet 1 Old
With oSh
oLr = .Cells(.Rows.Count, "C").End(xlUp).Row
r = 1
For i = 1 To oLr
If IsNumeric(.Range("C" & i).Value) And _
.Range("C" & i) <> "" Then
tSh.Range("S" & r).Value = oSh.Range("C" & i).Value
r = r + 1
End If
Next i
End With
tSh.Activate ' compare the two lists and leave only the new items
With tSh
tLr = .Cells(.Rows.Count, "T").End(xlUp).Row
sLr = .Cells(.Rows.Count, "S").End(xlUp).Row
r = 0
For x = 1 To tLr
For f = 1 To sLr
If tSh.Range("S" & x).Value = tSh.Range("T" & f).Value Then
Exit For
Else
tSh.Range("Q" & r).Value = tSh.Range("T" & x).Value
End If
Next f
r = r + 1
Next x
qLr = .Cells(.Rows.Count, "Q").End(xlUp).Row
For x = qLr To 1 Step -1
For f = sLr To 1 Step -1
If tSh.Range("S" & f).Value = tSh.Range("Q" & x).Value Then
tSh.Range("Q" & x).Delete Shift:=xlUp
End If
Next f
Next x
End With
xLr = tSh.Cells(tSh.Rows.Count, "Q").End(xlUp).Row ' build array for only new order numbers
Set xRng = tSh.Range("Q1:Q" & xLr)
ReDim tRay(1 To xLr)
For x = 1 To xLr
tRay(x) = tSh.Range("Q" & x).Value
Next x
oSh.Activate ' Select ' start copying the old orders with status values to sheet3
With oSh
oLr = oSh.Cells(.Rows.Count, "C").End(xlUp).Row
Set oRng = oSh.Range("C1:C" & oLr)
Set tRng = Application.Workbooks(1).Sheets(3).Range("A1")
For nCell = 1 To UBound(nRay)
For oCell = 1 To oLr
If oSh.Range("C" & oCell).Value = nRay(nCell) Then
Set tCell = oSh.Range("A" & oCell)
Set tCell = tCell.Resize(1, 13)
tCell.Copy Destination:=tRng.Offset(1)
Set tCell = tCell.Offset(2, 1).CurrentRegion
tCell.Copy Destination:=tRng.Offset(3, 1)
tLr = tSh.Cells(tSh.Rows.Count, "B").End(xlUp).Row
Set tRng = tSh.Range("A" & tLr).Offset(1)
End If
Next oCell
tLr = tSh.Cells(tSh.Rows.Count, "B").End(xlUp).Row
Set tRng = tSh.Range("A" & tLr).Offset(1)
Next nCell
End With
nSh.Activate ' Select ' Add in the new orders to the new sheet
With nSh
nLr = nSh.Cells(.Rows.Count, "C").End(xlUp).Row
Set nRng = nSh.Range("C2:C" & nLr)
For xCell = 1 To UBound(tRay)
For nCell = 1 To nLr
If nSh.Range("C" & nCell).Value = tRay(xCell) Then
Set tCell = nSh.Range("A" & nCell)
Set tCell = tCell.Resize(1, 13)
tCell.Copy Destination:=tRng.Offset(1)
Set tCell = tCell.Offset(2, 1).CurrentRegion
tCell.Copy Destination:=tRng.Offset(3, 1)
tLr = tSh.Cells(tSh.Rows.Count, "B").End(xlUp).Row
Set tRng = tSh.Range("A" & tLr).Offset(1)
End If
Next nCell
tLr = tSh.Cells(tSh.Rows.Count, "B").End(xlUp).Row
Set tRng = tSh.Range("A" & tLr).Offset(1)
Next xCell
End With
' tSh.Columns("Q:T").ClearContents
tSh.Range("A2:M2").Delete Shift:=xlUp
End Sub
