Does it actually crash or merely go into an endless loop, as I would expect
just at a glance at your code. Try changing

CELLCount = CELLCount + 1
End If
Loop

to

End If
CELLCount = CELLCount + 1
Loop

In passing I'd suggest -
Head the module Option Explicit
declare all your variables
don't use variable names like Text & Number
If you are going to qualify .Cells to your sheet with 'With' might as well
qualify all the instances instead of only some. Might not matter in this
case as your 'With' sheet is the Activesheet, otherwise it would give
errors.

Regards,
Peter T

"Nolaughmtr" wrote in message
...
Sub copy_1()
Dim SourceRange As Range, DestRange As Range
Dim DestSheet As Worksheet, Lr As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'fill in the Source Sheet and range
Set SourceRange = Sheets("WE 9-8-07").Range("F2:G63")

'Fill in the destination sheet and call the LastRow
'function to find the last row
Set DestSheet = Sheets("DIE STATUS")
Lr = DestSheet.Cells(Rows.count, "A").End(xlUp).Row

'With the information from the LastRow function we can
'create a destination cell and copy/paste the source range
Set DestRange = DestSheet.Range("A" & Lr + 1)
SourceRange.COPY DestRange

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Worksheets("DIE STATUS").Activate
CELLCount = 2
With Worksheets("Die status")
Do While Cells(CELLCount, "A") < ""

Number = Val(Cells(CELLCount, "A"))
Text = Cells(CELLCount, "A")
If InStr(Text, " ") 0 Then
Text = Trim(Mid(Text, InStr(Text, " ")))
.Cells(CELLCount, "A") = Number
.Cells(CELLCount, "C") = Text
CELLCount = CELLCount + 1
End If
Loop
End With

End Sub