Sub copyProjectDates()
Dim sourceFile As Workbook
Dim DestFile As Workbook
Dim copyStartCell As Range
Dim copyEndCell As Range
Dim copyRange As Range
Dim destRange As Range
Dim destStartCell As Range
Dim destEndCell As Range
Dim foundCell As Range
Dim c As Range
Dim searchData As String
Dim foundAddress As String
Dim foundRow As String

'speed things up a bit
Application.ScreenUpdating = False

'Set sourceFile = GetObject("C:\1-Joanne\Excel\Projects
'Overview.xls")
set SourceFile = Workbooks.Open( filename:= _
"C:\1-Joanne\Excel\Projects Overview.xls")
For Each c In Range("B4:B42")
If c < "" Then
searchData = c.Value
With sourceFile.Sheets("Sheet1")
Set foundCell = .Cells.Find(What:=searchData, _
After:=.Cells(1,1), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not foundCell Is Nothing Then 'project is found
set copyStartCell = foundCell.Offset(0, 10)
set copyEndCell = foundCell.Offset(0, 15)
set copyRange = Range(copyStartCell,copyEndCell)
set destStartCell = c.Offset(0, 12)
set destEndCell = c.Offset(0, 17)
set destRange = Range(destStartcell,destEndCell)
c.Offset(0, -1).Value = foundRow
foundCell.Interior.Color = vbRed
Else 'project not found
c.Interior.Pattern = xlPatternLightHorizontal
End If
End With
End If
Next
'sourceFile.Close SaveChanges:=True
End Sub

Might be a start. I wouldn't use GetObject to open the file.

--
Regards,
Tom Ogilvy

"jowatkins" wrote in message
...
Hi,

I want to automate copying data from one workbook to another. The
program should copy cells from one workbook where the project name
matches that in the base workbook.

heres the code

Sub copyProjectDates()
Dim sourceFile As Workbook
Dim DestFile As Workbook
Dim copyStartCell As Range
Dim copyEndCell As Range
Dim copyRange As Range
Dim destRange As Range
Dim destStartCell As Range
Dim destEndCell As Range
Dim foundCell As Range
Dim c As Range
Dim searchData As String
Dim foundAddress As String
Dim foundRow As String

'speed things up a bit
Application.ScreenUpdating = False

Set sourceFile = GetObject("C:\1-Joanne\Excel\Projects
Overview.xls")
For Each c In Range("B4:B42")
If c < "" Then
searchData = c.Value
With sourceFile.Sheets("Sheet1")
Set foundCell = .Cells.Find(What:=searchData, _
After:=[A1], _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows,
_

SearchDirection:=xlNext, _
MatchCase:=False)

If Not foundCell Is Nothing Then 'project is found
copyStartCell = foundCell.Offset(0, 10)
copyEndCell = foundCell.Offset(0, 15)
copyRange = ("copyStartCell : copyEndCell")
destStartCell = c.Offset(0, 12)
destEndCell = c.Offset(0, 17)
destRange = ("destStartcell : destEndCell")
c.Offset(0, -1).Value = foundRow
foundCell.Interior.Color = vbRed
Else 'project not found
c.Interior.Pattern = xlPatternLightHorizontal
End If
End With
End If
Next
'sourceFile.Close SaveChanges:=True
End Sub

I'm getting a "object variable or with block variable not set" error on
the following line
________________________________________
copyStartCell = foundCell.Offset(0, 10)
________________________________________

Any ideas? Cheers, Jo


---
Message posted from http://www.ExcelForum.com/