Macro causing column issue and memory error...

[porter]

Good morning (it is morning here in Vancouver),

I am hoping someone will have an answer for me. I have a macro setup that moves data from one worksheet to another worksheet (one tab within my workbook to another) based on data submitted via an inputbox. The code is below. The problem I am having is that, when even one row of info is transferred to the "CLOSED" tab, the sheet all of a sudden has the maximum amount of columns ("XFD", or something like that, being the last column) and I get a memory error when trying to delete that row - and I cannot, of course, "undo" the macro (so I have to close without saving and reopen or delete the columns).

Could someone have a look at this code and tell me what I have to do to eliminate the problem. I have a similar code in another workbook that does not illicit the same problem with columns when the macro is activated. Thanks...

Sub CLOSEJOB()
'
' CLOSEJOB Macro
'
' Keyboard Shortcut: Ctrl+Shift+C
'
'FROM WIP
Application.ScreenUpdating = False
Dim LastRow&, SearchString$, FirstAddress$, _
    fCell As Range, dCell As Range, RecCopied%
RecCopied = 0
SearchString = InputBox(prompt:="Enter the JOB NUMBER to CLOSE", Title:="CLOSE JOB")
If SearchString = "" Then GoTo INVUSAGE
Sheets("WIP").Select
LastRow = Sheets("WIP").Cells(Rows.Count, "C").End(xlUp).Row
''//Assumes you have headers in row 1
With Sheets("WIP").Range("A7:A" & LastRow)
  Set fCell = .Find(What:=SearchString, LookIn:=xlFormulas, LookAt:=xlPart)
  If fCell Is Nothing Then
    MsgBox SearchString & " was not found in the WIP sheet.", , SearchString & " Not Found"
    GoTo INVUSAGE
  End If
  FirstAddress = fCell.Address
  Do
    Sheets("COMPLETED").Cells(Rows.Count, "C").End(xlUp)(2).EntireRow.Value = fCell.EntireRow.Value
    RecCopied = RecCopied + 1
    If dCell Is Nothing Then
      Set dCell = fCell
    Else
      Set dCell = Union(fCell, dCell)
    End If
    Set fCell = .FindNext(fCell)
  Loop While Not fCell Is Nothing And Not fCell.Address = FirstAddress
  dCell.EntireRow.Delete
  MsgBox RecCopied & " records were found and closed.", , "Success"
End With
'END OF WIP CLOSE
'FROM INVENTORY USAGE
INVUSAGE:
Sheets("INVUSAGE").Select
LastRow = Sheets("INVUSAGE").Cells(Rows.Count, "C").End(xlUp).Row
''//Assumes you have headers in row 1
With Sheets("INVUSAGE").Range("A4:A" & LastRow)
  Set fCell = .Find(What:=SearchString, LookIn:=xlFormulas, LookAt:=xlPart)
  If fCell Is Nothing Then
    MsgBox SearchString & " was not found in the INVENTORY USAGE sheet.", , SearchString & " Not Found"
    GoTo LastLine
  End If
  FirstAddress = fCell.Address
  Do
    Sheets("INVCOMPLETE").Cells(Rows.Count, "C").End(xlUp)(2).EntireRow.Value = fCell.EntireRow.Value
    RecCopied = RecCopied + 1
    If dCell Is Nothing Then
      Set dCell = fCell
    Else
      Set dCell = Union(fCell, dCell)
    End If
    Set fCell = .FindNext(fCell)
  Loop While Not fCell Is Nothing And Not fCell.Address = FirstAddress
  dCell.EntireRow.Delete
  MsgBox RecCopied & " records were found and closed.", , "Success"
End With
'END OF INVENTORY USAGE CLOSE
LastLine:
Sheets("MAIN").Select
Application.ScreenUpdating = True
End Sub