Problem copying from one workbook to anoth

[jowatkins]

Hi,

I want to automate copying data from one workbook to another. Th
program should copy cells from one workbook where the project nam
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\Project
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 o
the following line
________________________________________
copyStartCell = foundCell.Offset(0, 10)
________________________________________

Any ideas? Cheers, J

 

[Tom Ogilvy]

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

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

 

[Heath]

This usually means that you are moving outside of the
range of your variable .

In your case it is because you set copyStartCell as
a range, but then you try to set it as a value. That
is the default value for .offset(x, y) anything.

Instead do like before Set copyStartCell = foundCell.Offset(0, 10)
(for your other ranges as well) and this should work fine.

Heath

 

[jowatkins]

Hi,

Thanks for the help, in case you couldn't tell I'm pretty new at this.
I made the changes that you suggested, but now I'm getting the "Objec
Required" error message on the following line:

Set copyStartCell = foundCell.Offset(0, 10)

J

 

[Tom Ogilvy]

Perhaps you should look at the the many changes I made to your flawed code
(no guarantee that there are not more) rather than just focus on the limited
suggestion provided by Heath. Or do you want to post back one error at a
time?

 

[jowatkins]

OK, sorry, I failed to see the other changes you had made. I've now
applied all the changes and the program apears to run smoothly.
However, when it is carrying out the copy and paste, the data is being
pasted into the sourceFile workbook, rather than the destFile.

I've tried doing it a bit differently, eg.

change

copyRange.Copy destRange

To.

copyRange.Copy destFile.Sheet1.destRange

And

copyRange.Select
Selection.Copy
destFile.Activate
Sheet1.Range(destStartCell, destEndCell).PasteSpecial xlPasteAll

but to no avail.

 

[Tom Ogilvy]

PasteSpecial xlPasteAll

is the same as a straight copy and paste, so you might as well just do that:
(not sure why you changed it? )

However,

For Each c In Range("B4:B42")

the Range("B4:B42") refers to the activeworksheet which would be in the
SourceFile. Thus c would be in the sourcefile and your destination is
specified relative to c. Perhaps this is the source of your problem.
Perhaps you need

for each c in DestFile.worksheets("Sheet1").Range("B4:B42")


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 DestFile = workbooks("Destination.xls")

'Set sourceFile = GetObject("C:\1-Joanne\Excel\Projects
'Overview.xls")
set SourceFile = Workbooks.Open( filename:= _
"C:\1-Joanne\Excel\Projects Overview.xls")
DestFile.worksheets("Sheet1").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
copyRange.Copy Destination:=destRange ' <== Added code
Else 'project not found
c.Interior.Pattern = xlPatternLightHorizontal
End If
End With
End If
Next
'sourceFile.Close SaveChanges:=True
End Sub