I don't remember where I got this code (which I have since slightly modified), but it's been a lifesaver a few times. Recovers both worksheets (in fully formatted and unformatted form, to ensure capture of cells containing more than 255 characters) and VBA modules. Paste the code into a Word VBA module. The comments up top provide more instructions. Set the recovery boolean variables appropriately before running.
Option Explicit
' Change the following file names in the code to something you want.
' The first ("XL.Workbooks.Open FileName:=" in the code) is the path
' and file name of the corrupted spreadsheet file.
' The second ("C:\temp\vbe_" in this example) includes the path and
' folder to put the exported contents of the corrupted spreadsheet.
'
' Establish a reference to the Microsoft Excel 9.0 Object Library: Tools,
' References, check the box next to this entry.
' Execute the code (cursor in module; press F5).
' if you get an File Open error message, click Debug, then Continue.
' When the code has executed, look in the Export File Name you indicated.
' You'll see a bunch of *.txt files.
' Open a new Excel spreadsheet.
' File/Import each of these txt files.
' Excel will rename the txt files to the original module name, although you
' may have to copy the contents of ThisWorkbook from a class module into
' the actual ThisWorkbook folder.
' Save the renewed spreadsheet. You're done!
Sub Recover_Excel_VBA_modules()
Dim XL As Excel.Application
Dim XLVBE As Object
Dim wb As Workbook
Dim sh As Worksheet
Dim i As Integer, j As Integer, k As Integer
Dim fname As String, s As String
Dim RecoverSheets As Boolean, RecoverModules As Boolean
'User input to define process below
fname = "c:\windows\desktop\publication catalog"
RecoverSheets = True
RecoverModules = False
Set XL = New Excel.Application
XL.Workbooks.Open FileName:=fname + ".xls"
If Not RecoverSheets Then GoTo GetModules
Set wb = XL.Workbooks.Add
If XL.Workbooks.Count > 1 Then
'successfully created second workbook, retrieve sheets into it
XL.Workbooks(1).Activate
For i = 1 To XL.Worksheets.Count
If i > 1 Then wb.Sheets.Add
Debug.Print XL.Sheets(i).Name
wb.ActiveSheet.Name = XL.Sheets(i).Name + " (unfmt)"
XL.Sheets(i).UsedRange.Copy wb.ActiveSheet.Range("A1"

XL.Sheets(i).Copy After:=wb.Sheets(wb.ActiveSheet.Name)
Workbooks(1).Activate
Next i
wb.SaveAs FileName:=fname & " - sheets.xls"
wb.Close
Else
For i = 1 To XL.Worksheets.Count
Set sh = XL.Sheets(i)
Debug.Print "Restoring " & sh.Name & " (" & sh.UsedRange.Rows.Count & " rows)"
Open "e:\recover\" & sh.Name & ".csv" For Output As #1
For j = 1 To sh.UsedRange.Rows.Count
s = """" & sh.Cells(j, 1) & """"
For k = 2 To sh.UsedRange.Columns.Count
s = s & ",""" & sh.Cells(j, k) & """"
Next k
Print #1, s
Next j
Close #1
Next i
End If
If Not RecoverModules Then GoTo SubDone
GetModules:
Set XLVBE = XL.VBE
j = XLVBE.VBProjects(1).VBComponents.Count
For i = 1 To j
Debug.Print XLVBE.VBProjects(1).VBComponents(i).Name
XLVBE.VBProjects(1).VBComponents(i).Export _
FileName:="e:\recover\" & _
XLVBE.VBProjects(1).VBComponents(i).Name & ".txt"
Next
SubDone:
XL.Quit
Set XL = Nothing
End Sub
Rob
![[flowerface] [flowerface] [flowerface]](/data/assets/smilies/flowerface.gif)