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.

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

Order Macro 150406.xlsm

**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

Thread: Help, loop finds overlaps, then adds not overlapped items, but misses the first match

Thread Tools

Display

Help, loop finds overlaps, then adds not overlapped items, but misses the first match

attached file

Tags for this Thread

Posting Permissions