Macro copy data into another workbook

[Ingo]

I found this small macro which copies the data from my source worksheet
("Data4") Range("A1:C1000") to a different workbook ("C:\Destination.xls").
What it does is that it will look for the next empty row and then copy the
data into it. Now I would like to alter the macro so instead of always
copying into the next empty row (and eventually create duplicates) it should
check for the whole range if an entry from column A in the source range
already exists in column A of the detination workbook and in this case
overwrite column B and C of this row in the destination workbook. In case it
does not exist yet, it should write the data in the empty row as the macro
below does already. One more note: the data of the cells in column A of the
source worksheet is always unique, there are no duplicates already in the
source worksheet. Thanks for your help!

Sub Test()
Dim bk As Workbook
Dim bSave As Boolean
Dim lRow As Long

' test to see if Destination.xls is already open

On Error Resume Next
Set bk = Workbooks("Destination.xls")
On Error GoTo 0
If bk Is Nothing Then
bSave = True
Set bk = Workbooks.Open("C:\Destination.xls")
End If

'find first empty row in database
lRow = bk.Worksheets("Test").Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
ThisWorkbook.Sheets("Data4").Range("A1:C1000").Copy _
Destination:=bk.Worksheets("Test").Cells(lRow, 1)

' if destination was originally closed, then save and close it

If bSave Then bk.Close Savechanges:=True

End Sub

 

[Joel]

Sub Test()
Dim bk As Workbook
Dim bSave As Boolean
Dim lRow As Long

' test to see if Destination.xls is already open

On Error Resume Next
Set bk = Workbooks("Destination.xls")
On Error GoTo 0
If bk Is Nothing Then
bSave = True
Set bk = Workbooks.Open("C:\Destination.xls")
End If

'find first empty row in database
lRow = bk.Worksheets("Test").Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
With ThisWorkbook.Sheets("Data4")
RowCount = 1
Do While .Range("A" & RowCount) <> ""
FindData = .Range("A" & RowCount)
Set c = bk.Columns("A:A").Find(what:=FindData, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Range("A" & RowCount & ":C" & RowCount).Copy _
Destination:=bk.Worksheets("Test").Range("A" & lRow)
lRow = lRow + 1
Else
.Range("A" & RowCount & ":C" & RowCount).Copy _
Destination:=bk.Worksheets("Test").Range("A" & c.row)
End If
RowCount = RowCount + 1
Loop

End With

' if destination was originally closed, then save and close it
If bSave Then bk.Close Savechanges:=True

End Sub

 

[Ingo]

Hello Joel,

thanks a lot for the very fast reply. When I copy your changes into the
workbook and try to run it, I get back the message "object doesn 't support
this property or method". Any idea what could be the reason for this error? I
'm working with Excel 2003 SP3. Thanks!

 

[Joel]

Sorry, I forgot the worksheet on one line

Set c = bk.Worksheets("Test").Columns("A").Find(what:=FindData, _
LookIn:=xlValues, lookat:=xlWhole)

 

[Ingo]

Thanks again Joel, it works perfectly now! Sorry to border you again, just
one more question: will this macro also work if the destination workbook is a
shared workbook und different users are using this code at the same time to
export some data into the destination workbook?