PDA

View Full Version : [SOLVED] Help, loop finds overlaps, then adds not overlapped items, but misses the first match



mperrah
04-06-2015, 03:56 PM
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.

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

mperrah
04-06-2015, 04:04 PM
13124

mperrah
04-07-2015, 03:29 PM
This is the code as I got it to work.
Must have had a typo or left a sheet reference out.
I fine tooth combed till I got the output as planned.
I'm sure this could be simplified and streamlined, I'm just stoked it works...
Hope this helps someone else.
-mark

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, 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 tRng = Application.Workbooks(1).Sheets("Combined").Range("A2")

For nCell = LBound(nRay) 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

Set tCell = tCell.Offset(2, 1).CurrentRegion
tCell.Copy Destination:=tRng.Offset(2, 1)
tLr = tSh.Cells(tSh.Rows.Count, "B").End(xlUp).Row
Set tRng = tSh.Range("A" & tLr).Offset(3)
End If
Next oCell
tLr = tSh.Cells(tSh.Rows.Count, "B").End(xlUp).Row
Set tRng = tSh.Range("A" & tLr).Offset(2)
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

For xCell = LBound(tRay) 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

End Sub