View Full Version : [SOLVED:] combine data from 2 workbooks with matching cells in different locations
mperrah
03-11-2015, 11:00 AM
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
03-12-2015, 08:23 AM
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
03-13-2015, 02:41 PM
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
03-19-2015, 10:01 AM
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
03-19-2015, 12:18 PM
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
03-20-2015, 12:35 PM
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
03-23-2015, 11:15 AM
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
03-23-2015, 02:24 PM
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
03-23-2015, 04:06 PM
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
03-24-2015, 10:49 AM
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
03-24-2015, 11:52 AM
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
03-25-2015, 09:13 AM
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
03-26-2015, 08:30 AM
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
03-26-2015, 09:26 AM
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
03-27-2015, 04:29 PM
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
04-01-2015, 08:56 AM
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
04-01-2015, 04:50 PM
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
04-01-2015, 05:01 PM
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
04-03-2015, 11:10 AM
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
04-03-2015, 11:16 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.