Copy and Paste link between workbooks
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
"PhilosophersSage" wrote:
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.
|