combine data from 2 workbooks with matching cells in different locations

[mperrah]

Here is a challenge, all input welcome,

I have 2 workbooks with similar data and formatting.
There are rows of orders, order number in Column 3 (C)
under each order is a blank row, then a header row, then items of the order (number of rows will vary)

I have a macro that adds header information and data validation cells. Column K and H in Row 1 only, then F, G and H under each order row.
Then validation values are updated in some cells daily.
The next day a new workbook with current orders needs to synchronize with yesterdays updated validation values.
Shipped orders will be gone, and new orders will be added to top.

The order# in Column C is unique so I'm thinking to use that to find order matches form each workbook.
The info needing to copy is in Columns F, G and H with different number of columns for each order with a blank row above and below.

Not sure the coding needed but something like this:



sub UpdateDataValue()

dim i as integer, j as integer
dim rng1 as Rang, rng2 as Range
dim oWb as Workbook, nWb as Workbook

with oWb ' define old workbook

rng1 =.Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Row

if Cells(3, rng1).Value = num then ' build an array of unique order numbers on old sheet value in column C
myArray1 = myArray1 + rng1.value

next rng1
end with

with nWb ' define new workbook

rng2 =.Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Row

if Cells(3, rng2).Value = num then ' build an array of unique order numbers on old sheet
myArray2 = myArray2 + rng2.value

next rng2
end with

for each rng2 in myArray2
if rng1.value = rng2.value Then
with nWb.Range(rng1 + 3, 6-8).Value = oWb.Range(rng2 + 3, 6-8).Value
end With
end if
next rng2

End Sub



Also, the number of order rows may change in new workbook, ie: if an order ships it will be missing from the the new wrkbook
The number of ordered items should match for each order from wb to wb.
the new wb has new orders added in on top so where the matching order numbers from wb to wb may be in different rows...

12989
I have attached then end result.
Im sure there is a way to get there, just cant see the best path.

Any help is greatly appreciated.

-mark

[mperrah]

12994
The areas in green have the unique order number in "column C"
Columns F, G, H have data I'm trying to copy to the new sheet in the same order numbers area, which could be at a different row then this sheet.
Also I am trying to copy data from columns K, and L that line up with the corresponding unique order number on the new sheet as well.
Some orders will not be present on the new sheet, so the data from this sheet with no matches can be ignored,
but matches need this sheets data moved to the new sheet in the corresponding order numbers area.
Also, there may be new orders on the new sheet that will have no match from the old sheet, these need no change.

I hope that makes sense. I'm attempting to find a match of order numbers, then offset down 3 then right 3 where the data I need is start copying the varying amounts of data, loop through to the first blank row, resize 3 columns to right, then copy and paste to new sheet.
I can run the macro from the new sheet or the old sheet if that makes anything easier?
I'm really stumped on this one...

[mperrah]

I made this code to create an array of unique order numbers,
next step is finding the match in the new sheet, then copying the appropriate data from old to new sheets.

This outputs the array to column "O" (just for testing) I will comment or delete that when I'm done.


Sub make_oRay()

Dim sh_src As Worksheet
Dim i As Integer
Dim lrD As Long
Dim p As Double
Dim r As Double
Dim oRay As Variant

Set sh_src = Worksheets("Sheet1")

sh_src.Select

With sh_src
lrD = Cells(Rows.Count, "C").End(xlUp).Row

ReDim oRay(1 To lrD)
r = 1
For i = 1 To lrD
If .Range("C" & i).Value < 90000 _
And .Range("C" & i).Value > 1 Then
oRay(r) = .Range("C" & i).Value
r = r + 1
End If

Next i

For p = LBound(oRay) To UBound(oRay)
.Range("O" & p).Value = oRay(p)
Next p

End With

End Sub

[mperrah]

New strategy. Id like to try scanning through the new order sheet and do one of 2 things.
1) If the order is missing from the old sheet - add/insert it to the old
2) If the order is on the old but not new -delete/remove from old sheet
- If the orders match on old and new - do nothing



old

new



1 - del




2

2



3

3



5 - del

4 - add




6 - add





with the match i need to resize the selection of the new order to include all the items of the order.
Each order number is in Column C, then there is a blank row, then several rows of items, then a blank row, then the next order row
Column A has a header in Row 1 then each order goes from Column A to J
the order items go from Column B to E with a blank row above and below.





A
B
C
D
E
F
G
H
I
J


1
ship date
order date
order #
s1
s2
s3
s4
s5
s6
s7


2
3/12/15
2/12/15
12300
o1
o2
o3
o4
o5
o6
o7


3












4

prod code
pkg
p code
qty







5

item1
case
ab12
2







6

item2
bottle
ab32
6







7












8
3/13/15
2/12/15
12331
o1
o2
o3
o4
o5
o6
o7


9












10

prod code
pkg
p code
qty







11

item1
case
ab31
10







12

[mperrah]

making progress,

trouble is selecting the cells around the matched find item...
I used arrow keys with xlLeft, Right Down and up, but it used hard values anyway...
with the match i shift all the way left column A,
then start selecting, shift all the way right column J,
then down to next cell and up one, then copy.

Then look for last row of sheet 3 and paste.



Sub A_Test_Combine()

Dim sh_n As Worksheet ' Sheet2 is the new order
Dim sh_o As Worksheet ' Sheet 1 is old
Dim sh_t As Worksheet ' Sheet 3 is temp
Dim i As Integer
Dim lrD, lrT As Long
Dim p As Double
Dim r As Double
Dim f As Variant
Dim oRay As Variant

Application.ScreenUpdating = False

Set sh_n = Worksheets("Sheet2")
Set sh_o = Worksheets("Sheet1")
Set sh_t = Worksheets("Sheet3")

With sh_n
lrD = Cells(Rows.Count, "C").End(xlUp).Row

ReDim oRay(1 To lrD)
r = 1
For i = 1 To lrD
If .Range("C" & i).Value < 90000 _
And .Range("C" & i).Value > 1 Then
oRay(r) = .Range("C" & i).Value
r = r + 1
End If

Next i

End With

With sh_o

For f = LBound(oRay) To UBound(oRay)

Cells.Find(What:=oRay(f), After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.End(xlToLeft).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Range("A21:J45").Select ' how do i get this to be variable ?
Selection.Copy

With sh_t

lrT = Cells(Rows.Count, "C").End(xlUp).Row

Range("A" & lrT).Select
.Paste
.EntireColumn.AutoFit
.EntireRow.AutoFit

End With

Next f

End With

Application.ScreenUpdating = True

End Sub

[mperrah]

This code is building 2 arrays, one for new orders and one for old orders
Then it compares (tries to) them for matches.
But my code errors out in that the first array has fewer entries then the second so the compare stops before all the values of both can be compared.
how can i build a loop that compares all the items of each array, they may not be in the same location of each array?
So if NewA has 9 items and OldA has 11 I need the loop to check 11 items, not stop at 9...
and sometimes the OldA might have fewer items then NewA.
Is there a way to loop what ever is the greater number of items?



Sub buildArray()

Dim OldA As Variant ' list of old orders
Dim NewA As Variant ' list of new orders
Dim itemArray As Variant ' list of items in an order
Dim sh_o As Worksheet ' old order list
Dim sh_n As Worksheet ' new order list
Dim sh_t As Worksheet ' temp order sheet
Dim p As Double
Dim i_o As Long
Dim i_n As Long
Dim x_o As Long
Dim x_n As Long
Dim r_o As Double
Dim r_n As Double
Dim lr_o As Long
Dim lr_n As Long

Set sh_o = Application.Worksheets("Sheet1")
Set sh_n = Application.Worksheets("Sheet2")
Set sh_t = Application.Worksheets("Sheet3")

Application.ScreenUpdating = False

With sh_n ' start building array with new order numbers

lr_n = Cells(Rows.Count, "C").End(xlUp).Row

ReDim NewA(1 To lr_n)
r_n = 1
For i_n = 1 To lr_n
If .Range("C" & i_n).Value < 90000 _
And .Range("C" & i_n).Value > 1 Then
NewA(r_n) = .Range("C" & i_n).Value
r_n = r_n + 1
End If

Next i_n

' For p = LBound(NewA) To UBound(NewA)
' .Range("O" & p + 1).Value = NewA(p)
' Next p
End With

With sh_o ' start buiding array with old numbers
lr_o = Cells(Rows.Count, "C").End(xlUp).Row

ReDim OldA(1 To lr_o)
r_o = 1
For i_o = 1 To lr_o
If .Range("C" & i_o).Value < 90000 _
And .Range("C" & i_o).Value > 1 Then
OldA(r_o) = .Range("C" & i_o).Value
r_o = r_o + 1
End If

Next i_o

End With

' start to compare old to new order numbers
With sh_t

' maybe use a for Each here?
For x_n = LBound(NewA) To UBound(NewA) ' new orders array count

For x_o = LBound(OldA) To UBound(OldA) ' old orders array count

If NewA(x_n) = OldA(x_o) Then ' look for matches

.Range("A" & x_n).Value = NewA(x_n) ' for testing print resulting matches

End If

Next x_o

Next x_n

End With

Application.ScreenUpdating = True

End Sub



any help or ideas are appreciated

thank you
-mark

[mperrah]

Maybe it would be easier to build 3 arrays
from sheet2 (the new orders) it copies all the data as NewA()
from sheet1 (the old orders with status values updated) copies all the data as OldA()
then a new array is built from only the union of these 2 arrays as TempA()
the trick is if the order from sheet1 is not present in sheet2 - its data gets removed or excluded from the new TempA() array because that order was shipped.
and if the order is present on both array - the data from sheet2 gets excluded from the new TempA() array,
so the updated status values from sheet1 are preserved, and only new orders from sheet2 get added.
then the resulting array TempA() gets output to sheet3.
I have attached a sample of the sheets 1,2 and 3 as I am trying to accomplish.
13053
Really stumped on this.

I figured xld would enjoy this.
maybe there is a pasta delivery service in Chile?

thanks in advance
-mark

[mperrah]

Found this code from Yongle,
Tried to modified for my project. Sarting with the order header row,
then if successful moving into the order items... not so much though

I get a subscript out of range when trying to compare 2 multidimensional arrays.
only column "C" is what I am comparing then copying the whole row (A:J) if they match to the results sheet3


Sub Search_Key_Words()

'declare and set variables
Dim LastRowK As Long, LastRowM As Long
Dim r As Integer, c As Integer, w As Integer, x As Integer, y As Integer, z As Integer
Dim arrayK() As Variant, arrayM() As Variant
Dim wsM As Worksheet, wsR As Worksheet, wsK As Worksheet
Set wsM = Sheets(1)
Set wsR = Sheets(3)
Set wsK = Sheets(2)
'clear old values in results sheet
wsR.Cells.ClearContents
'determine last row
LastRowK = wsK.Range("C2").End(xlDown).Row
LastRowM = wsM.Range("C2").End(xlDown).Row
'set dimensions of array
ReDim arrayK(2 To LastRowK - 1, 1 To 12)
'place keywords in array
For x = 2 To LastRowK
If wsK.Range("C" & x).Value < 90000 _
And wsK.Range("C" & x).Value > 1 Then
For c = 1 To 12
arrayK(x, c) = wsK.Cells(x, c).Value
Next c
End If
Next x
'build old orders array
ReDim arrayM(2 To LastRowM - 1, 1 To 12)
For x = 2 To LastRowM
If wsM.Range("C" & x).Value < 90000 _
And wsM.Range("C" & x).Value > 1 Then
For c = 1 To 12
arrayM(x, c) = wsK.Cells(x, c).Value
Next c
End If
Next x
'create header row and set first row for data in results sheet
wsM.Range("A1:J1").Copy
wsR.Range("A1:J1").PasteSpecial xlPasteValues
z = 2
'run through keywords (new orders) for matches in old
For k = 0 To UBound(arrayK)
For r = 0 To UBound(arrayM)
c = 3 '
If arrayK(k, c).Value = arrayM(r, c).Value Then ' <<<Subscript out of Range error
For y = 1 To 12
wsR.Cells(z, y) = arrayM(r, y)
Next y
z = z + 1 'adds 1 to row number in results sheet
Else
'do nothing
End If
Next r
Next k
End Sub

[mperrah]

Got this to find matches of order numbers,
need to add in the new orders in from sheet 2
then ill have a list to work from for building the items array for each order..
going to explore array(x).address as a possibility



Sub ListMatches()
Dim O_Rng As Range
Dim N_Rng As Range
Dim O_Cell As Range
Dim N_Match As Range
Dim T_Rng As Range
Dim lrO As Long, lrN As Long
Dim Start_Match As String
Dim Count As Variant

lrO = ThisWorkbook.Sheets("Sheet1").Range("O2").End(xlDown).Row ' arbitrary column to store temp match results
Set O_Rng = ThisWorkbook.Sheets("Sheet1").Range("O2:O" & lrO)

lrN = ThisWorkbook.Sheets("Sheet2").Range("O2").End(xlDown).Row
Set N_Rng = ThisWorkbook.Sheets("Sheet2").Range("O2:O" & lrN)

Set T_Rng = ThisWorkbook.Sheets("Sheet3").Range("A1")

For Each O_Cell In N_Rng
With O_Rng
Set N_Match = .Find(What:=O_Cell, After:=O_Rng.Range("A1").End(xlDown))
If N_Match Is Nothing Then GoTo O_CellNext

Start_Match = N_Match.Address
Do
Count = Count + 1
' Set N_Match = N_Match.Resize(1, 12)
N_Match.Copy Destination:=T_Rng
Set T_Rng = T_Rng.Offset(1, 0)
Set N_Match = .FindNext(After:=N_Match.Range("A1"))
Loop Until N_Match.Address = Start_Match
End With

O_CellNext:
Next O_Cell

If Count = "" Then Count = "No"
MsgBox Count & " Orders were combined"

End Sub

[mperrah]

A nice step forward,

i got this code to build an array from the new order sheet that finds a match in an array of the old orders,
then resize the matches' address to include the cells next to the match,
and copy the results to a new location. yeah!

now i need preform a similar task on the old sheet instead of the trimmed down array,
and then copy data adjacent to the matches from the old orders to the new order sheets' corresponding matching order number address

then be able to perform this match copy and paste for the items below each order.
Fun, fun


Sub compare_oRay()

Dim sh_o, sh_n, sh_t As Worksheet
Dim wb As Workbook
Dim i As Integer
Dim lr, lrA, lrC As Long
Dim p, r As Double
Dim n_Cell, o_Cell, t_Cell As Range
Dim N_Rng, O_Rng, T_Rng As Range
Dim oRay, nRay, tRay As Variant
Dim wbCnt As Integer
Dim Start_Match As String

Application.ScreenUpdating = False

Set sh_o = Sheets(1)
Set sh_n = Sheets(2)
Set sh_t = Sheets(3)
Set T_Rng = Sheets(3).Range("D1")

sh_n.Select

With sh_n
lr = Cells(Rows.Count, "C").End(xlUp).Row

ReDim nRay(1 To lr)
r = 1
For i = 1 To lr
If .Range("C" & i).Value < 90000 _
And .Range("C" & i).Value > 1 Then
nRay(r) = .Range("C" & i).Value
r = r + 1
End If
Next i
End With

With sh_t
For p = LBound(nRay) To UBound(nRay)
.Range("C" & p).Value = nRay(p)
Next p
End With

sh_o.Select

With sh_o
lr = Cells(Rows.Count, "C").End(xlUp).Row

ReDim oRay(1 To lr)
r = 1
For i = 1 To lr
If .Range("C" & i).Value < 90000 _
And .Range("C" & i).Value > 1 Then
oRay(r) = .Range("C" & i).Value
r = r + 1
End If
Next i
End With

With sh_t
For p = LBound(oRay) To UBound(oRay)
.Range("A" & p).Value = oRay(p)
Next p

lrA = Cells(Rows.Count, "A").End(xlUp).Row
lrC = Cells(Rows.Count, "C").End(xlUp).Row

Set N_Rng = Sheets(3).Range("C1:C" & lrC)
Set O_Rng = Sheets(3).Range("A1:A" & lrA)

For Each n_Cell In N_Rng
With O_Rng
Set t_Cell = .Find(What:=n_Cell, After:=O_Rng.Range("A1").End(xlDown))
If t_Cell Is Nothing Then GoTo n_CellNext

Start_Match = t_Cell.Address
Do
Count = Count + 1
Set t_Cell = t_Cell.Resize(1, 2)
t_Cell.Copy Destination:=T_Rng
Set T_Rng = T_Rng.Offset(1, 0)
Set t_Cell = .FindNext(After:=t_Cell.Range("A1"))
Loop Until t_Cell.Address = Start_Match
End With

n_CellNext:
Next n_Cell

End With
sh_t.Select

Application.ScreenUpdating = True

End Sub

[mperrah]

Here are some images of what I'm struggling with.
not sure if i need to use an array or how loop through both sheets to produce desired results.

1305613057

any help is much appreciated
thank you

[mperrah]

Here is some code from SamT (Thank you) I modified for my project,
it errors out when I try to resize the range from resulting match cell address.
I'm not sure if the match is a value or a cell address?

I'm trying to loop through every value of column c on sheet 1
to match the value from the nRay() array i built
when the match is found go to column A then resize to column J and copy
then paste to next blank row on sheet3
anyone see what im doing wrong?


Sub compare_oRayToColumn()

Dim sh_o, sh_n, sh_t As Worksheet
Dim wb As Workbook
Dim i As Integer
Dim lr, lrA, lrC As Long
Dim p, r As Double
Dim n_Cell, o_Cell, t_Cell, o_Match As Range
Dim N_Rng, O_Rng, T_Rng As Range
Dim oRay, nRay, tRay As Variant
Dim wbCnt As Integer
Dim Start_Match As String

Application.ScreenUpdating = False

Set sh_o = Sheets(1)
Set sh_n = Sheets(2)
Set sh_t = Sheets(3)
Set T_Rng = Sheets(3).Range("A1")

sh_n.Select

With sh_n
lr = Cells(Rows.Count, "C").End(xlUp).Row

ReDim nRay(1 To lr)
r = 1
For i = 1 To lr
If .Range("C" & i).Value < 90000 _
And .Range("C" & i).Value > 1 Then
nRay(r) = .Range("C" & i).Value
r = r + 1
End If
Next i
End With

With sh_o
lrC = Cells(Rows.Count, "C").End(xlUp).Row

Set O_Rng = Sheets(1).Range("C2:C" & lrC)

For n_Cell = LBound(nRay) To UBound(nRay)
For o_Cell = 2 To lrC
If .Cells(o_Cell, 3).Value = nRay(n_Cell) Then

o_Match = o_Cell.Address ' not sure on this <<<

Set o_Match = .Cells(o_Cell, 3).Offset(0, -2).Resize(0, 11) ' errors out on this line
o_Match.Copy Destination:=T_Rng

Set T_Rng = T_Rng.Offset(1, 0)
End If
Next o_Cell
Next n_Cell
End With

sh_t.Select

Application.ScreenUpdating = True

End Sub

[mperrah]

tried many variations but now I get an error as marked below
"Runtime error code 91, object block or with block variable not defined ?

Can anyone see what I'm missing, Please.


Sub compare_oRayToColumn()

Dim sh_o, sh_n, sh_t As Worksheet
Dim i, r As Integer
Dim lrN, lrO As Long
Dim n_Cell, o_Cell, o_Match As Range
Dim O_Rng, T_Rng As Range
Dim nRay As Variant

Application.ScreenUpdating = False

Set sh_o = Sheets(1)
Set sh_n = Sheets(2)
Set sh_t = Sheets(3)
Set T_Rng = Sheets(3).Range("A1")

lrN = sh_n.Cells(Rows.Count, "C").End(xlUp).Row
lrO = sh_o.Cells(Rows.Count, "C").End(xlUp).Row

sh_n.Select
With sh_n

ReDim nRay(1 To lrN)
r = 1
For i = 1 To lrN
If .Range("C" & i).Value < 90000 And .Range("C" & i).Value > 1 Then
nRay(r) = .Range("C" & i).Value
r = r + 1
End If
Next i
End With

sh_o.Select
With sh_o

For n_Cell = LBound(nRay) To UBound(nRay)
For o_Cell = 2 To lrO
If .Cells(o_Cell, 3).Value = nRay(n_Cell) Then

o_Match = .Cells(o_Cell, 1) ' < runtime error 91 object block or with block variable not set ?

Set o_Match = .Cells(o_Cell, 1).Resize(0, 11)
o_Match.Copy Destination:=T_Rng

Set T_Rng = T_Rng.Offset(1, 0)

End If
Next o_Cell
Next n_Cell
End With

sh_t.Select

Application.ScreenUpdating = True

End Sub


Looking forward to help on this, thank you.

[mperrah]

Thought maybe I had a typo so I altered my naming structure for better consistency,
and I was looking at one of xld's other posts and noticed the phrasing for my cell range was off.
this now works for finding the match and copying to sheet3


Sub compare_oRayToColumn()

Dim oSh, nSh, tSh As Worksheet
Dim i, r As Integer
Dim nLr, oLr As Long
Dim nCell, oCell, oMatch As Range
Dim oRng, tRng As Range
Dim nRay As Variant

Application.ScreenUpdating = False

Set oSh = Sheets(1)
Set nSh = Sheets(2)
Set tSh = Sheets(3)
Set tRng = Sheets(3).Range("A1")

nLr = nSh.Cells(Rows.Count, "C").End(xlUp).Row
oLr = oSh.Cells(Rows.Count, "C").End(xlUp).Row

nSh.Select
With nSh

ReDim nRay(1 To nLr)
r = 1
For i = 1 To nLr
If .Range("C" & i).Value < 90000 And .Range("C" & i).Value > 1 Then
nRay(r) = .Range("C" & i).Value
r = r + 1
End If
Next i
End With

oSh.Select
With oSh

For nCell = LBound(nRay) To UBound(nRay)
For oCell = 2 To oLr
If .Range("C" & oCell).Value = nRay(nCell) Then

Set oMatch = .Range("A" & oCell & ":J" & oCell) ' -this was the change that got it going, yeah
oMatch.Copy Destination:=tRng

Set tRng = tRng.Offset(1, 0)

End If
Next oCell
Next nCell
End With

tSh.Select

Application.ScreenUpdating = True

End Sub



Hope im not offending anyone by posting this whole process.
I always find the best help here, and hope the steps I take and post may help someone else (and me in the process)

[mperrah]

I have these 2 files, one is has the macros I run to combine data from the second workbook into this one.
the copy function causes the cell and font colors to be different from the source.
I've tried copy paste with source formatting but I cant get the object types correct.
Can anyone see where I am messing up?
Thank you.

I run the macro called aRunAllMacros with alt + F8 and choose from the list.

I may make it an on load script once the debugging is done.

Thank you.
1308513086

[mperrah]

I offer this challenge up to the gurus...

Getting an "Object Required" error here
Trying to scan through rows for a Single match form all the elements of an array
not sure what type of object is needed or where.
This sub is designed for the sample sheets I have attached earlier in post #1
Not sure if the Do/Loop method is the best for this attempt either.
I'm really stumped here. Thank you


Sub findInArray()

Dim oSh, nSh, tSh As Worksheet
Dim wb As Workbook
Dim i As Integer
Dim p, r, oLr, nLr As Long
Dim nCell, oCell, tCell, nRng, oRng, tRng As Range
Dim nRay As Variant
Dim EndFind As String

Application.ScreenUpdating = False

Set oSh = Application.Workbooks(1).Sheets(1)
Set nSh = Application.Workbooks(1).Sheets(2)
Set tSh = Application.Workbooks(1).Sheets(3)
Set tRng = Application.Workbooks(1).Sheets(3).Range("A1")

nSh.Select
With nSh
nLr = .Cells(.Rows.Count, "C").End(xlUp).Row
ReDim nRay(1 To nLr)
r = 1
For i = 1 To nLr
If IsNumeric(.Range("C" & i).Value) Then
nRay(r) = .Range("C" & i).Value
r = r + 1
End If
Next i
End With

oSh.Select
With oSh
oLr = oSh.Cells(.Rows.Count, "C").End(xlUp).Row
Set oRng = oSh.Range("C2:C" & oLr)
For Each oCell In nRay
With oRng
Set oCell = oRng.Find(What:=oCell)
If oCell Is Nothing Then GoTo oCellNext
endArray = UBound(nRay)
Do
tCell = oCell.Offset(0, -2).resize(1, 10)
tCell.Copy Destination:=tRng ' Object Required here?!
Set tRng = tRng.Offset(1, 0)
' Set tCell = oRng.FindNext(After:=tCell.Range("C2"))
Loop Until oCell = endArray
' End If
End With
oCellNext:
Next oCell

End With
tSh.Select

Application.ScreenUpdating = True

End Sub

[mperrah]

13107
I attached the file with macro and output for reference.
I deleted rows 250 and down to decrease file size.

I appreciate your help on this.
-mark
:think::banghead:

[mperrah]

Caution - this code fills data till end of sheet before errors out (takes ten minutes on my pc).

It builds an array from sheet2
finds a match on sheet1 then using offset and resize copies to sheet3
If no match is found I need a match from sheet2 copied to sheet3 using similar offset and resize
I get hung up in the Do While loop to avoid copying duplicates to sheet3

I have tried moving the Do While loop to different if locations,
I've tried swapping which if to run inside and out (array first or range first)

All help is very appreciated.
can anyone see what I'm missing or doing wrong?
I'm sure there is a more efficient way to manage this problem, I just cant find it.


Sub findInArray()

Dim oSh, nSh, tSh As Worksheet
Dim wb As Workbook
Dim i, x, j As Integer
Dim p, r, oLr, nLr, tLr As Long
Dim nCell, oCell, tCell, nRng, oRng, tRng, mRng As Range
Dim nRay As Variant
Dim StMatch As Boolean

Application.ScreenUpdating = False

Set oSh = Application.Workbooks(1).Sheets(1)
Set nSh = Application.Workbooks(1).Sheets(2)
Set tSh = Application.Workbooks(1).Sheets(3)
Set tRng = Application.Workbooks(1).Sheets(3).Range("A1")

tSh.Range("A1:L1").Value = oSh.Range("A1:L1").Value

nSh.Select
With nSh
nLr = .Cells(.Rows.Count, "C").End(xlUp).Row
ReDim nRay(1 To nLr)
r = 1
For i = 1 To nLr
If IsNumeric(.Range("C" & i).Value) And _
.Range("C" & i) <> "" Then
nRay(r) = .Range("C" & i).Value
r = r + 1
End If
Next i
End With

oSh.Select
With oSh
oLr = oSh.Cells(.Rows.Count, "C").End(xlUp).Row
Set oRng = oSh.Range("C2:C" & oLr)
Set nRng = nSh.Range("C2:C" & nLr)
tLr = tSh.Cells(tSh.Rows.Count, "B").End(xlUp).Row


For j = LBound(nRay) To UBound(nRay)
For x = 1 To tLr
If tSh.Range("C" & x).Value = nRay(j) Then
StMatch = True
End If

Do While StMatch = False
For nCell = LBound(nRay) To UBound(nRay)
For oCell = 2 To oLr
' tLr = tSh.Cells(tSh.Rows.Count, "B").End(xlUp).Row
' Set mRng = tSh.Range("C1:C" & tLr)
If oSh.Range("C" & oCell).Value = nRay(nCell) Then
Set tCell = oSh.Range("A" & oCell)
Set tCell = tCell.resize(1, 12)
tCell.Copy Destination:=tRng.Offset(1)

Set tCell = tCell.Offset(2, 1).CurrentRegion
tCell.Copy Destination:=tRng.Offset(3, 1)
tLr = tSh.Cells(Rows.Count, "B").End(xlUp).Row
Set tRng = tSh.Range("A" & tLr).Offset(2)

ElseIf nSh.Range("C" & oCell).Value = nRay(nCell) Then

Set tCell = nSh.Range("A" & oCell)
Set tCell = tCell.resize(1, 12)
tCell.Copy Destination:=tRng.Offset(1)

Set tCell = tCell.Offset(2, 1).CurrentRegion
tCell.Copy Destination:=tRng.Offset(3, 1)
tLr = tSh.Cells(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
Loop
Next x
Next j
End With

tSh.Select

Application.ScreenUpdating = True

End Sub

[mperrah]

Not pretty, but it works.
Finally got the copy and paste working like I was hoping for.
I'm sure there is a better way and I reuse a lot of code that is redundant, but it works.
If anyone has some play time and wants to stream line this feel free.
I added some comments to show the steps. I need to work on formating and adding back an outline,

I hope this helps anyone trying to copy and paste non-contiguous cells based on a target range values.

-mark



Sub findInArray()

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

Application.ScreenUpdating = False

Set oSh = Application.Workbooks(1).Sheets(1)
Set nSh = Application.Workbooks(1).Sheets(2)
Set tSh = Application.Workbooks(1).Sheets(3)

tSh.Range("A1:L1").Value = oSh.Range("A1:L1").Value

nSh.Select ' build list of new order numbers from sheet 2
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
ReDim nRay(1 To aLr)
For t = 1 To aLr
nRay(t) = tSh.Range("T" & t).Value
Next t

oSh.Select ' build a list of old orders sheet 1
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.Select ' 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

oSh.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("C2:C" & oLr)
Set tRng = Application.Workbooks(1).Sheets(3).Range("A1")

For nCell = LBound(nRay) To UBound(nRay)
For oCell = 2 To oLr
If oSh.Range("C" & oCell).Value = nRay(nCell) Then
Set tCell = oSh.Range("A" & oCell)
Set tCell = tCell.resize(1, 12)
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(2)
End If
Next oCell
tLr = tSh.Cells(tSh.Rows.Count, "B").End(xlUp).Row
Set tRng = tSh.Range("A" & tLr).Offset(1)
Next nCell

' build array for only new order numbers
xLr = tSh.Cells(tSh.Rows.Count, "Q").End(xlUp).Row
Set xRng = tSh.Range("T1:T" & xLr)
ReDim tRay(1 To xLr)
For x = 1 To xLr
tRay(x) = tSh.Range("T" & x).Value
Next x

nSh.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 = LBound(tRay) To UBound(tRay)
For nCell = 2 To nLr
If nSh.Range("C" & nCell).Value = tRay(xCell) Then
Set tCell = nSh.Range("A" & nCell)
Set tCell = tCell.resize(1, 12)
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(2)
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 With
Application.ScreenUpdating = True

End Sub

[mperrah]

Here is the file if anyone is interested.
Thank you for humoring me through my exploration.
All of the progress in the project came from searching this forum.
So thanks to the team for helping realize a dream.
13119