P
PhilosophersSage
J_Knowles helped me out with this macro; it is very useful for transferring
data from one workbook to another and has been very helpful for the short
term; however, I still need to create a link to the data as some people who
use the destination data file do not have access to both files and cannot run
the macro.
http://www.microsoft.com/office/com...&p=1&tid=96068e06-fa13-4bc1-ade8-75c6f3091b9f
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("destination.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, 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 "All Connections and Ring-out information has been updated."
End Sub
data from one workbook to another and has been very helpful for the short
term; however, I still need to create a link to the data as some people who
use the destination data file do not have access to both files and cannot run
the macro.
http://www.microsoft.com/office/com...&p=1&tid=96068e06-fa13-4bc1-ade8-75c6f3091b9f
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("destination.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, 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 "All Connections and Ring-out information has been updated."
End Sub