Run-Time error '3349': Numeric field overflow.

[James Leech]

I am having some trouble with a module i am working on. The modules purpose
is to merge and sort some worksheets from an excel file into a new worksheet
and save as a new file (This excel file is pe linked to my access database).
The sub continues by executing a delete command to clear the xls datas'
destination table before running an append query to fill it with the new
data. Finally the temporary excel file created earlier is deleted.

My problem is i can run the code two or three times, then access will raise
the following error:

Run-Time error '3349': Numeric field overflow.

I have also notice that the excel thread is still runnning in the process
pool (via task manager ) from the first time when it was used to manipulate
the data and save it to a new file.

Have I overlooked somethink - here is my code:

Option Compare Database

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Public Function MergeAndSort()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim wb As Workbook
Dim mycmd As Command

Set wb = Workbooks.Open(Filename:="C:\1MyDocs\Unifran\UNpend.xls")

On Error Resume Next
If Len(wb.Worksheets.Item("Master").Name) = 0 Then
On Error GoTo 0
Excel.Application.ScreenUpdating = False
Set DestSh = wb.Worksheets.Add
DestSh.Name = "Master"
For Each sh In wb.Worksheets
If sh.Name <> DestSh.Name And sh.Name <> "Index" Then
Last = LastRow(DestSh)

'sh.UsedRange.Copy DestSh.Cells(Last + 1, "A")
'Instead of this line you can use the code below to copy
only the values
'or use the PasteSpecial option to paste the format also.

With sh.UsedRange
DestSh.Cells(Last + 1, "A").Resize(.Rows.Count,
..Columns.Count).Value = .Value
End With

sh.UsedRange.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
Excel.Application.CutCopyMode = False
End With
End If
Next

Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Range("B:B,E:E,G:G,H:H,I:I,J:J,L:L,CX:CX,CY:CY,CZ:CZ,DAA,DBB,DCC,DDD,DEE").Select
Range("E1").Activate
Selection.Delete Shift:=xlToLeft

Excel.Application.ScreenUpdating = True

wb.SaveAs ("C:\1MyDocs\Unifran\UnPendImport.xls")

Set wb = Nothing

Set wb =
Workbooks.Open(Filename:="C:\1MyDocs\Unifran\UnPendImport.xls")

DoCmd.OpenQuery "qDeleteAllFMAData"
DoCmd.OpenQuery "qAppendXLSData"

wb.Close (False)
Set wb = Nothing

Dim KillFile As String
KillFile = "C:\1MyDocs\Unifran\UnPendImport.xls"
'Check that file exists
If Len(Dir$(KillFile)) > 0 Then
'First remove readonly attribute, if set
SetAttr KillFile, vbNormal
'Then delete the file
Kill KillFile

Excel.Application.Quit
End If
Else
MsgBox "The worksheet Master already exists. Manually delete this
worksheet and run this again or proceed straight to the Merge procedure to
continue."
End If
End Function

Thanks in advance for any help/guidance.

Regards
James
tgl