Copy and Paste link between workbooks

[PhilosophersSage]

I have several workbooks, source data (SD) and destination data (DD) which
are portions of SD, I would like to make a macro that would search for
matching values between SD column L & DD column B and if there is a match
copy a link from SD column H, J & K to DD column N, O & P this way I can
reduce entry points for data.

The big problem I have is the search between workbooks, also I cannot get
the paste function to give a link between workbooks. Any help or pointers
anyone can give me I would really appreciate it! Thank you!

 

[PhilosophersSage]

Still cannot figure out search and compare function but was able to figure
out copy link function. Just cannnot get the varables to work. I tried adding
a varable to the code but then it would not work. any pointers on search and
varable help is much appreciate, thank you!

Windows("source data.xlsm").Activate
Range("H266").Select 'would like to change to Range("H"&RowVar1)
Selection.Copy
Windows("Destination data.xlsx").Activate
Range("N45").Select 'would like to change to Range("N"&RowVar2)
ActiveSheet.Paste Link:=True
Windows("source data.xlsm").Activate
Range("J266").Select 'would like to change to Range("H"&RowVar1)
Application.CutCopyMode = False
Selection.Copy
Windows("Destination data.xlsx").Activate
Range("O45").Select' would like to change to Range("N"&RowVar2)
ActiveSheet.Paste Link:=True
Windows("source data.xlsm").Activate
Range("K266").Select 'would like to change to Range("H"&RowVar1)
Application.CutCopyMode = False
Selection.Copy
Windows("Destination data.xlsx").Activate
Range("P45").Select 'would like to change to Range("N"&RowVar2)
ActiveSheet.Paste Link:=True

 

[PhilosophersSage]

Ok figured out what I did wrong... had file names wrong in varable so the
code now works. Please help with searching wkbk1 data column L using data in
wkbk2 column B as search peramater and return row number to RowVar1.

Windows(wkbk1).Activate
Range("H" & RowVar1).Select
Selection.Copy
Windows(wkbk2).Activate
Range("N" & RowVar2).Select
ActiveSheet.Paste Link:=True
Windows(wkbk1).Activate
Range("J" & RowVar1).Select
Application.CutCopyMode = False
Selection.Copy
Windows(wkbk2).Activate
Range("O" & RowVar2).Select
ActiveSheet.Paste Link:=True
Windows(wkbk1).Activate
Range("K" & RowVar1).Select
Application.CutCopyMode = False
Selection.Copy
Windows(wkbk2).Activate
Range("P" & RowVar2).Select
ActiveSheet.Paste Link:=True

 

[J_Knowles]

You do not have to use copy & paste.
First worksheet name = source
Second worksheet name = destination
See if this will work.

Sub FindMatches()
Dim sd As Worksheet
Dim dd As Worksheet
Dim cell As Range
Dim x As Long
Dim LastRowS As Long
Dim LastRowD As Long
Set sd = Worksheets("source")
Set dd = Worksheets("destination")
sd.Activate
LastRowS = Cells(Cells.Rows.Count, "L").End(xlUp).Row
Set rngS = Range("L2:L" & LastRowS)
dd.Activate
LastRowD = Cells(Cells.Rows.Count, "B").End(xlUp).Row
For x = 2 To LastRowD
For Each cell In rngS
If dd.Cells(x, 2).Value = cell.Value Then
dd.Cells(x, 14).Formula = cell.Offset(0, -4).Value
dd.Cells(x, 15).Formula = cell.Offset(0, -2).Value
dd.Cells(x, 16).Formula = cell.Offset(0, -1).Value
End If
Next
Next x
End Sub


HTH

 

[J_Knowles]

Okay, this code is for the source & destination in separate workbooks.
The first try was for one workbook with 2 worksheets.

Sub FindMatchesInBooks()
Dim swb As Workbook, dwb As Workbook
Dim sd As Worksheet, dd As Worksheet
Dim cell As Range, x As Long
Dim LastRowS As Long, LastRowD As Long
Application.ScreenUpdating = False
Set swb = Workbooks("SourceData.xlsx") ' change to your workbook name
Set dwb = Workbooks("FindValuesSh1-CopyToSht2.xlsm") ' change filename
Set sd = Worksheets("source")
Set dd = Worksheets("destination")
swb.Activate
sd.Activate
LastRowS = Cells(Cells.Rows.Count, "L").End(xlUp).Row
Set rngS = Range("L2:L" & LastRowS)
dwb.Activate
dd.Activate
LastRowD = Cells(Cells.Rows.Count, "B").End(xlUp).Row
For x = 2 To LastRowD
For Each cell In rngS
If dd.Cells(x, 2).Value = cell.Value Then
dd.Cells(x, 14).Formula = cell.Offset(0, -4).Value
dd.Cells(x, 15).Formula = cell.Offset(0, -2).Value
dd.Cells(x, 16).Formula = cell.Offset(0, -1).Value
End If
Next
Next x
Application.ScreenUpdating = True
End Sub

HTH

 

[PhilosophersSage]

Had to move the set sd and dd til after workbook activated. but for the most
part the code works to copy data; however, it seems to skip a few lines. It
may be because not all the data is congruant. Also I would like the macro to
paste a line back to origonal cell rather then just the data.

Sub FindMatchesInBooks()
Dim swb As Workbook, dwb As Workbook
Dim sd As Worksheet, dd As Worksheet
Dim cell As Range, x As Long
Dim LastRowS As Long, LastRowD As Long
Application.ScreenUpdating = False
Set swb = Workbooks("Source.xlsm") ' change to source data filename
Set dwb = Workbooks("destinatio.xlsx") ' change to destination data
filename
swb.Activate
Set sd = Worksheets("Sheet 5") 'Source worksheet
sd.Activate
LastRowS = Cells(Cells.Rows.Count, "L").End(xlUp).Row
Set rngS = Range("L2:L" & LastRowS)
dwb.Activate
Set dd = Worksheets("Sheet 3") ' Destination worksheet
dd.Activate
LastRowD = Cells(Cells.Rows.Count, "B").End(xlUp).Row
For x = 2 To LastRowD
For Each cell In rngS
If dd.Cells(x, 2).Value = cell.Value Then
dd.Cells(x, 13).Formula = cell.Offset(0, -6).Value 'Sets column
M source to column F
dd.Cells(x, 14).Formula = cell.Offset(0, -4).Value 'Sets column
N source to column H
dd.Cells(x, 15).Formula = cell.Offset(0, -2).Value 'Sets Column
O source to column J
dd.Cells(x, 16).Formula = cell.Offset(0, -1).Value 'Sets Column
P source to column K
End If
Next
Next x
Application.ScreenUpdating = True
MsgBox "DOne"
End Sub

 

[J_Knowles]

Here is the revised code. I used the Worksheet.UsedRange.Rows.Count to get
the number of row cells, redefined sd & dd. and pasted in the references to
the source workbook. Both workbooks need to be opened before running the
routine.

Sub FindMatchesInBooksR1()
Dim swb As Workbook, dwb As Workbook
Dim sd As Worksheet, dd As Worksheet
Dim cell As Range, x As Long
Dim LastRowS As Long, LastRowD As Long
Application.ScreenUpdating = False
Set swb = Workbooks("SourceData.xlsx") ' change workbook name
Set dwb = Workbooks("FindValuesSh1-CopyToSht2.xlsm") ' change workbook
Set sd = swb.Worksheets("source") 'revised code
Set dd = dwb.Worksheets("destination") 'revised code
sd.Activate
LastRowS = ActiveSheet.UsedRange.Rows.Count 'revised code
Set rngS = Range("L2:L" & LastRowS)
dd.Activate
LastRowD = ActiveSheet.UsedRange.Rows.Count 'revised code
For x = 2 To LastRowD
For Each cell In rngS
If dd.Cells(x, 2).Value = cell.Value Then
'revised code
dd.Cells(x, 14).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -4).Address(False, False)
dd.Cells(x, 15).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -2).Address(False, False)
dd.Cells(x, 16).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -1).Address(False, False)
End If
Next
Next x
Application.ScreenUpdating = True
End Sub


HTH

 

[PhilosophersSage]

I get a Runtime Error 1004 when trying to execute this code.

dd.Cells(x, 14).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -4).Address(False, False)

Here is the revised code. I used the Worksheet.UsedRange.Rows.Count to get
the number of row cells, redefined sd & dd. and pasted in the references to
the source workbook. Both workbooks need to be opened before running the
routine.

Sub FindMatchesInBooksR1()
Dim swb As Workbook, dwb As Workbook
Dim sd As Worksheet, dd As Worksheet
Dim cell As Range, x As Long
Dim LastRowS As Long, LastRowD As Long
Application.ScreenUpdating = False
Set swb = Workbooks("SourceData.xlsx") ' change workbook name
Set dwb = Workbooks("FindValuesSh1-CopyToSht2.xlsm") ' change workbook
Set sd = swb.Worksheets("source") 'revised code
Set dd = dwb.Worksheets("destination") 'revised code
sd.Activate
LastRowS = ActiveSheet.UsedRange.Rows.Count 'revised code
Set rngS = Range("L2:L" & LastRowS)
dd.Activate
LastRowD = ActiveSheet.UsedRange.Rows.Count 'revised code
For x = 2 To LastRowD
For Each cell In rngS
If dd.Cells(x, 2).Value = cell.Value Then
'revised code
dd.Cells(x, 14).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -4).Address(False, False)
dd.Cells(x, 15).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -2).Address(False, False)
dd.Cells(x, 16).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -1).Address(False, False)
End If
Next
Next x
Application.ScreenUpdating = True
End Sub


HTH
--
Data Hog

Had to move the set sd and dd til after workbook activated. but for the most
part the code works to copy data; however, it seems to skip a few lines. It
may be because not all the data is congruant. Also I would like the macro to
paste a line back to origonal cell rather then just the data.

 

[J_Knowles]

The Activate command (to select the workbook & worksheet) may be the problem.

Sub FindMatchesInBooksR2()
Dim swb As Workbook, dwb As Workbook
Dim sd As Worksheet, dd As Worksheet
Dim cell As Range, x As Long
Dim LastRowS As Long, LastRowD As Long
Application.ScreenUpdating = False
Set swb = Workbooks("SourceData.xlsx") ' change workbook name
Set dwb = Workbooks("FindValuesSh1-CopyToSht2.xlsm") ' change workbook
Set sd = Worksheets("source")
Set dd = Worksheets("destination")
swb.Activate
sd.Activate
LastRowS = ActiveSheet.UsedRange.Rows.Count 'revised code
Set rngS = Range("L2:L" & LastRowS)
dwb.Activate
dd.Activate
LastRowD = ActiveSheet.UsedRange.Rows.Count ' revised code
For x = 2 To LastRowD
For Each cell In rngS
If dd.Cells(x, 2).Value = cell.Value Then
dd.Cells(x, 14).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -4).Address(False, False)
dd.Cells(x, 15).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -2).Address(False, False)
dd.Cells(x, 16).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -1).Address(False, False)
End If
Next
Next x
Application.ScreenUpdating = True
End Sub



--
Data Hog

I get a Runtime Error 1004 when trying to execute this code.

dd.Cells(x, 14).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -4).Address(False, False)

Here is the revised code. I used the Worksheet.UsedRange.Rows.Count to get
the number of row cells, redefined sd & dd. and pasted in the references to
the source workbook. Both workbooks need to be opened before running the
routine.

Sub FindMatchesInBooksR1()
Dim swb As Workbook, dwb As Workbook
Dim sd As Worksheet, dd As Worksheet
Dim cell As Range, x As Long
Dim LastRowS As Long, LastRowD As Long
Application.ScreenUpdating = False
Set swb = Workbooks("SourceData.xlsx") ' change workbook name
Set dwb = Workbooks("FindValuesSh1-CopyToSht2.xlsm") ' change workbook
Set sd = swb.Worksheets("source") 'revised code
Set dd = dwb.Worksheets("destination") 'revised code
sd.Activate
LastRowS = ActiveSheet.UsedRange.Rows.Count 'revised code
Set rngS = Range("L2:L" & LastRowS)
dd.Activate
LastRowD = ActiveSheet.UsedRange.Rows.Count 'revised code
For x = 2 To LastRowD
For Each cell In rngS
If dd.Cells(x, 2).Value = cell.Value Then
'revised code
dd.Cells(x, 14).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -4).Address(False, False)
dd.Cells(x, 15).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -2).Address(False, False)
dd.Cells(x, 16).Formula = "=[" & swb.Name & "]" & sd.Name & _
"!" & cell.Offset(0, -1).Address(False, False)
End If
Next
Next x
Application.ScreenUpdating = True
End Sub


HTH
--
Data Hog

Had to move the set sd and dd til after workbook activated. but for the most
part the code works to copy data; however, it seems to skip a few lines. It
may be because not all the data is congruant. Also I would like the macro to
paste a line back to origonal cell rather then just the data.