Find existing number in another workbook

[Lindleman]

I am using vba code to copy data from various excel sheets to a master
(database) excel sheet. These are invoices that I track. I create the
invoices and then execute a macro to copy and paste the data to the
master sheet in the proper columns. Right now, I simply find the last
row with data and insert the new data into the next available row. I
would like to be able to check to see if the invoice number exists and
have a dialog box pop up and ask if the data should be overwritten. If
the result is yes, I would like to copy the new data over the existing
row of cells in the master sheet. I will paste my current code below.

On Error Resume Next
Workbooks.Open Filename:= _
"C:\...\Invoicing.xls"
Application.ScreenUpdating = False
ThisWorkbook.Activate
Application.Goto Reference:="Inv_Number"
Selection.Copy
Windows("Invoicing.xls").Activate
Sheets("Invoices").Select
Application.Goto Reference:="Invoice"
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
Application.Goto Reference:="Cust_No"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
Application.Goto Reference:="Cust_Name"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

etc.

End Sub

Thanks in advance for any help with this!

 

[Joel]

Sub test()
'Const Filename = "C:\...\Invoicing.xls"
Const Filename = "C:\temp\Invoicing.xls"

On Error Resume Next
Workbooks.Open Filename:=Filename

Application.ScreenUpdating = False
ThisWorkbook.Activate
Application.Goto Reference:="Inv_Number"
searchdata = Selection.Value
Selection.Copy
Windows("Invoicing.xls").Activate
Sheets("Invoices").Select

Application.Goto Reference:="Invoice"

Set Startcell = Selection
Set endcell = Selection.End(xlDown)

Set c = Range(Startcell, endcell). _
Find(what:=searchdata, LookIn:=xlValues)

response = vbYes
If Not c Is Nothing Then
response = _
MsgBox("Do You want to over-write the data?", vbYesNo)
End If

If response = vbYes Then

endcell.Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


ThisWorkbook.Activate
Application.Goto Reference:="Cust_No"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
Application.Goto Reference:="Cust_Name"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End Sub

 

[Lindleman]

Sub test()
'Const Filename = "C:\...\Invoicing.xls"
Const Filename = "C:\temp\Invoicing.xls"

On Error Resume Next
Workbooks.Open Filename:=Filename

Application.ScreenUpdating = False
ThisWorkbook.Activate
Application.Goto Reference:="Inv_Number"
searchdata = Selection.Value
Selection.Copy
Windows("Invoicing.xls").Activate
Sheets("Invoices").Select

Application.Goto Reference:="Invoice"

Set Startcell = Selection
Set endcell = Selection.End(xlDown)

Set c = Range(Startcell, endcell). _
Find(what:=searchdata, LookIn:=xlValues)

response = vbYes
If Not c Is Nothing Then
response = _
MsgBox("Do You want to over-write the data?", vbYesNo)
End If

If response = vbYes Then

endcell.Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

ThisWorkbook.Activate
Application.Goto Reference:="Cust_No"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
Application.Goto Reference:="Cust_Name"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End Sub







- Show quoted text -

Thanks for the reponse!

This doesn't seem to work properly. I copied your code, but it seems
to bring up the dialog box every time, whether the invoice number
exists or not. Even then, it writes the new data at the bottom of the
database rather than overwriting the existing records like I need it
to do. Maybe I did something wrong?

 

[Joel]

This fixes the problem with over-writing the data. It iwll now over-write.
Can't figure out why the msgbox always comes up. I'll let yuou know when I
find the solution.

Sub test()
'Const Filename = "C:\...\Invoicing.xls"
Const Filename = "C:\temp\Invoicing.xls"

On Error Resume Next
Workbooks.Open Filename:=Filename

Application.ScreenUpdating = False
ThisWorkbook.Activate
Application.Goto Reference:="Inv_Number"
searchdata = Selection.Value
Selection.Copy
Windows("Invoicing.xls").Activate
Sheets("Invoices").Select

Application.Goto Reference:="Invoice"

Set Startcell = Selection
Set endcell = Selection.End(xlDown)

Set c = Range(Startcell, endcell). _
Find(what:=searchdata, LookIn:=xlValues)

response = vbYes
endcell.Select
If Not c Is Nothing Then
response = _
MsgBox("Do You want to over-write the data?", vbYesNo)
If response = vbYes Then
c.Select
End If
End If

If response = vbYes Then
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


ThisWorkbook.Activate
Application.Goto Reference:="Cust_No"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
Application.Goto Reference:="Cust_Name"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End Sub

 

[Joel]

This should fix the problems

Sub test()
'Const Filename = "C:\...\Invoicing.xls"
Const Filename = "C:\temp\Invoicing.xls"

On Error Resume Next
Workbooks.Open Filename:=Filename

Application.ScreenUpdating = False
ThisWorkbook.Activate
Application.Goto Reference:="Inv_Number"
searchdata = Selection.Value
Selection.Copy
Windows("Invoicing.xls").Activate
Sheets("Invoices").Select

Application.Goto Reference:="Invoice"

StartRow = Selection.Row
searchColumn = Selection.Column
EndRow = Cells(Rows.Count, searchColumn). _
End(xlUp).Row

Found = False
For RowCount = StartRow To EndRow
If searchdata = Cells(RowCount, searchColumn) Then
Found = True
Exit For
End If
Next RowCount

response = vbYes
If Found = True Then
response = _
MsgBox("Do You want to over-write the data?", vbYesNo)
If response = vbYes Then
End If
End If

If response = vbYes Then
Cells(RowCount, searchColumn).Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


ThisWorkbook.Activate
Application.Goto Reference:="Cust_No"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
Application.Goto Reference:="Cust_Name"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End Sub

 

[Lindleman]

This fixes the problem with over-writing the data. It iwll now over-write.
Can't figure out why the msgbox always comes up. I'll let yuou know when I
find the solution.

Sub test()
'Const Filename = "C:\...\Invoicing.xls"
Const Filename = "C:\temp\Invoicing.xls"

On Error Resume Next
Workbooks.Open Filename:=Filename

Application.ScreenUpdating = False
ThisWorkbook.Activate
Application.Goto Reference:="Inv_Number"
searchdata = Selection.Value
Selection.Copy
Windows("Invoicing.xls").Activate
Sheets("Invoices").Select

Application.Goto Reference:="Invoice"

Set Startcell = Selection
Set endcell = Selection.End(xlDown)

Set c = Range(Startcell, endcell). _
Find(what:=searchdata, LookIn:=xlValues)

response = vbYes
endcell.Select
If Not c Is Nothing Then
response = _
MsgBox("Do You want to over-write the data?", vbYesNo)
If response = vbYes Then
c.Select
End If
End If

If response = vbYes Then
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

ThisWorkbook.Activate
Application.Goto Reference:="Cust_No"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ThisWorkbook.Activate
Application.Goto Reference:="Cust_Name"
Application.CutCopyMode = False
Selection.Copy
Windows("Invoicing.xls").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End Sub







- Show quoted text -

Evidently, the FIND function is not working. I stepped through it and
it just selects the last record and overwrites it whether it matches
the search or not. I guess that is also why the dialog box always pops
up as well.

 

[Lindleman]

- Show quoted text -

Disregard the last post. I tried the new code and it seems to be
caught in an endless loop between these:

If searchdata = Cells(RowCount, searchColumn) Then
Found = True
Exit For
End If
Next RowCount

Thanks again for your assistance.

 

[Lindleman]

Disregard the last post. I tried the new code and it seems to be
caught in an endless loop between these:

If searchdata = Cells(RowCount, searchColumn) Then
Found = True
Exit For
End If
Next RowCount

Thanks again for your assistance.- Hide quoted text -

- Show quoted text -

Also, It seems to be overwriting my header row (row1) instead of
copying over the found data area.

 

[Joel]

To stop the over-writing of the header cell change one line as shown below.
The endless loop problem is simple the value in endrow. Check to see if the
endrow value actually matches what is in the worksheet. If you have a 1000
lines of data it may seem to be looping forever. You can highlight rowcount
and right click mouse. Then select add to watch so you can see if is
counting properly. Also add endrow to watch.

from:
StartRow = Selection.Row
to:
StartRow = Selection.Row + 1

 

[Lindleman]

To stop the over-writing of the header cell change one line as shown below.
The endless loop problem is simple the value in endrow. Check to see if the
endrow value actually matches what is in the worksheet. If you have a 1000
lines of data it may seem to be looping forever. You can highlight rowcount
and right click mouse. Then select add to watch so you can see if is
counting properly. Also add endrow to watch.

from:
StartRow = Selection.Row
to:
StartRow = Selection.Row + 1






- Show quoted text -

OK, it does finally get past that area, but the header is still being
overwritten. Any way I can send you the workbooks so you can see what
is going on?

Thanks!

 

[Joel]

(e-mail address removed)

OK, it does finally get past that area, but the header is still being
overwritten. Any way I can send you the workbooks so you can see what
is going on?

Thanks!

 

[Lindleman]

(e-mail address removed)






...

read more »- Hide quoted text -

- Show quoted text -

They must be truncating email addresses for privacy. Maybe you can
email me at: (llong at midsouthtechnologies dot com)