Analyse corruption and issue with your excel file
Some of the following VBA source code was given to me by Microsoft Support. I have modified, and improved on it to make it clearer and with better code. It is one of the most useful tool to find the issue in some workbook. It will write on a text file in your c:/test folder. You will have to create such folder if it does not exists.
Option Explicit
Sub Analyze_Workbook_In_One_File()
On Error GoTo 0
Dim currentDirectory
Dim sht
Dim x As Integer
Dim ver As String
Dim y, z
Dim var
Dim varLen
Dim wbName
Dim fName As String
Dim wbExt
Dim styCount
Dim msg
Dim sp
Dim ref As Reference
Dim shtCount
Dim shtHidden
Dim shtName, shtType
Dim startTime, endTime, totTime
Dim sty
Dim styCount2, zz
Dim nmName
Dim nmRefersTo
Dim nmValue
Dim nmCount
Dim nm As Name
Dim nmRefersToLength
Dim shpCount, totalShapeCount
Dim shp As Shape
Dim shpTLC As String
Dim shpVisible
Dim urRows As Double
Dim urColumns As Double
Dim urTotalCells As Double
Dim chTotal, lnTotal, ctComponents
Dim frmCount
Dim optionTest
Dim aLinks, i
Dim printFormulas
Dim startType
Dim xx, objTop, objLeft, objHeight, objWidth, badCount
Dim obj As Object
Dim vw As CustomView
Dim wb As Workbook
Dim us
Dim commentCount
Dim cmmt
Dim str1, str2, cellError
Dim cel, celFormula, formulaCount, celValue
Dim qName
Dim qType
Dim qConnection
Dim qCommandText
Dim qCount
Dim q As QueryTable
Dim qDestination
Application.EnableEvents = False
currentDirectory = CurDir
ChDir "C:\Test"
ChDir currentDirectory
printFormulas = MsgBox("Do You Want to Print Out All Formulas and Cells with Errors?" & Chr(10) & Chr(13) & "This may take a long time, 30 minutes or more.", vbYesNo + vbCritical, "PRINT FORMULAS?")
Application.ScreenUpdating = False
sp = " : "
wbName = ActiveWorkbook.Name
wbExt = InStr(1, wbName, ".")
wbName = Left(wbName, wbExt - 1)
'Debug.Print wbName
fName = "C:\Test\Analyze_Workbook_In_One_File_" & wbName & ".txt"
On Error Resume Next
'Since the file does not exists, if there are an error there, it should be ignored
Kill fName
On Error GoTo 0
fOpenOutput fName
'=========================================================
msg = "Checking the Age of the Workbook , the path length, and the Author."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "------------------------------------------------"
fPrint ""
'=========================================================
fPrint ""
fPrint "---------------------" & ActiveWorkbook.Name & "--------------------"
fPrint ""
fPrint "---------------------" & ActiveWorkbook.FullName & "--------------------"
fPrint ""
For Each z In ActiveWorkbook.BuiltinDocumentProperties
y = y + 1
Select Case y
Case 3
fPrint "---------------------" & z.Name & " : " & z.Value & "--------------------"
fPrint ""
Case 11
fPrint "---------------------" & z.Name & " : " & z.Value & "--------------------"
fPrint ""
Case Else
End Select
Next
'=========================================================
msg = "SHEETS AND VISIBILITY - looking for hidden and very hidden sheets that the customer may not know are there."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "------------------------------------------------"
fPrint ""
fPrint "This workbook has " & ActiveWorkbook.Sheets.Count & " sheets."
fPrint "Sheet Name" & sp & "Sheet Type" & sp & "Visiblity" '& sp & "Sheet Type"
For Each sht In ActiveWorkbook.Sheets
shtCount = shtCount + 1
shtHidden = sht.Visible
If shtHidden = 0 Then ver = "Hidden"
If shtHidden = 2 Then ver = "Very Hidden by Code"
If shtHidden = -1 Then ver = "Visible"
shtName = sht.Name
shtType = TypeName(sht)
If (TypeName(sht) = "Worksheet") And (sht.Type = 3) Then
shtType = "XL4 Macro Sheet"
End If
If ver <> "Visible" Or shtCount > 200 Then
fPrint shtCount & sp & sht.Name & sp & shtType & sp & ver
End If
Next
'=========================================================
msg = "STYLES - XL2003 has 8 default styles. XL2007 has 50 default styles. Checking for numerous Styles or for styles with names using unprintable characters or that might not be 'User Friendly'"
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint "This workbook has " & ActiveWorkbook.Styles.Count & " Styles."
fPrint ""
styCount2 = ActiveWorkbook.Styles.Count
For zz = styCount2 To 1 Step -1
styCount = styCount + 1
fPrint styCount & sp & ActiveWorkbook.Styles(zz).Name & sp & "BuiltIn:=" & ActiveWorkbook.Styles(zz).BuiltIn
If ActiveWorkbook.Styles(zz).BuiltIn = False Then
' ActiveWorkbook.Styles(zz).Delete 'Un-Comment this if you want to delete styles.
End If
Next
'=========================================================
msg = "DEFINED NAMES - Looking for Defined Names that have lost their reference (#REF), start with '\' (Originated in Lotus 123), have unprintable characters (Corrupt), dont look like they were created by a human (Created by a virus or an addin), or an exceedingly large number of Names (more than 500)."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
fPrint "Total Names are : " & ActiveWorkbook.Names.Count
fPrint ""
fPrint "Name Count : Name : RefersTo : Visible (True / False) : Length of RefersTo "
For Each nm In ActiveWorkbook.Names
'nm.Delete
nmName = nm.Name
nmValue = nm.Value
nmRefersTo = nm.RefersTo
nmRefersToLength = Len(nmRefersTo)
nmCount = nmCount + 1
'If (InStr(1, nmRefersTo, "#REF") > 0) Or (InStr(1, nmValue, "#") > 0) Then
If (InStr(1, nmRefersTo, "#REF") > 0) Or (nmRefersToLength > 200) Then
fPrint " BAD!!!! " & nmCount & " : " & nmName & sp & "'" & nmRefersTo & sp & nm.Visible & sp & nmRefersToLength
'nm.Delete 'Un-Comment this if you want to delete bad names.
Else
If nmCount > 500 Then
'Debug.Print nmCount & sp & nmName & sp & nmRefersTo & sp & nm.Visible
fPrint nmCount & sp & nmName & sp & "'" & nmRefersTo & sp & nm.Visible & sp & nmRefersToLength
'If nm.Visible = False Then nm.Delete 'Un-Comment thios if you want to delete hidden names.
End If
End If
Next
'=========================================================
msg = "SHAPES - Looking for shapes with Zero (0) Width or Height. Looking for Sheet ShapeCount to be a huge number > 200. Looking for shapes on a sheet to be in the same location, same Top and Left."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
UnHideAllColumnsAndRows
fPrint "Shape Count " & sp & "Sheet Shape Count" & sp & "Sheet Name" & sp & "Shape Name" & sp & "Shape Top" & sp & "Shape Left" & sp & "Shape Height" & sp & "Shape Width" & sp & "Shape Visible" & sp & "Shape Top Left Cell"
For Each sht In ActiveWorkbook.Worksheets
sht.Visible = True
shtName = sht.Name
For Each shp In sht.Shapes
If shp.Visible = msoFalse Then
shpVisible = "Hidden"
Else
shpVisible = "Visible"
End If
On Error Resume Next
shpTLC = shp.TopLeftCell.Address
totalShapeCount = totalShapeCount + 1
shpCount = shpCount + 1
If (shp.Height = 0) Or (shp.Width = 0) Then
fPrint "BAD!!! " & sp & totalShapeCount & sp & shpCount & sp & sht.Name & sp & shp.Name & sp & shp.Top & sp & shp.Left & sp & shp.Height & sp & shp.Width & sp & shpVisible & sp & shpTLC
Else
If totalShapeCount > 200 Then
fPrint totalShapeCount & sp & shpCount & sp & sht.Name & sp & shp.Name & sp & shp.Top & sp & shp.Left & sp & shp.Height & sp & shp.Width & sp & shpVisible & sp & shpTLC
End If
End If
Next
shpCount = 0
Next
'=========================================================
msg = "USED RANGE - Looking for a large last number, then check to see if there is actually data there. A large Used Range causes a file to be unnecessarily big."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
For Each sht In ActiveWorkbook.Worksheets
sht.Select
urRows = sht.UsedRange.Rows.Count
urColumns = sht.UsedRange.Columns.Count
urTotalCells = urRows * urColumns
'urTotalCells = CStr(urTotalCells)
If urTotalCells > 100000 Then
fPrint " LARGE USED RANGE" & sp & sht.Name & sp & sht.UsedRange.Address & sp & urTotalCells
Else
' fPrint sht.Name & sp & sht.UsedRange.Address & sp & urTotalCells
End If
Next
'=========================================================
msg = "LINKS - Looking for two (2) or more links to the same workbook, or for a large number of links."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
aLinks = ActiveWorkbook.LinkSources(xlOLELinks)
If Not IsEmpty(aLinks) Then
fPrint "....OLE Links...."
For i = 1 To UBound(aLinks)
fPrint i & sp & CStr(aLinks(i))
Next
Else: End If
aLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(aLinks) Then
fPrint "....Excel Links...."
For i = 1 To UBound(aLinks)
fPrint i & sp & CStr(aLinks(i))
Next
Else: End If
'=========================================================
msg = "LinesAndCharacters - Checking for over 20K of code in a code module. It has been observed that modules that have over 20K of code will ocassionally hang or crash Excel. If just one function is used in the Module, all the code in the Module has to be loaded at once. If this area is blank, it is because the VBA Project is password protected for viewing, or that 'Trust Access to the VBA Project' is not checked in Macro Security."
fPrint " "
fPrint msg
fPrint " "
fPrint ""
ctComponents = ActiveWorkbook.VBProject.VBComponents.Count
For x = 1 To ActiveWorkbook.VBProject.VBComponents.Count
ver = ActiveWorkbook.VBProject.VBComponents(x).Name
For y = 1 To ActiveWorkbook.VBProject.VBComponents(x).CodeModule.CountOfLines
var = ActiveWorkbook.VBProject.VBComponents(x).CodeModule.Lines(y, 1)
varLen = varLen + Len(var)
Next
If varLen > 20000 Then
fPrint ver & ":" & ActiveWorkbook.VBProject.VBComponents(x).CodeModule.CountOfLines & " lines of code."
fPrint "BAD!!!!!!!!!!! " & ver & " has " & varLen & " characters"
Else
' fPrint ver & ":" & ActiveWorkbook.VBProject.VBComponents(x).CodeModule.CountOfLines & " lines of code."
' fPrint ver & " has " & varLen & " characters"
End If
lnTotal = lnTotal + ActiveWorkbook.VBProject.VBComponents(x).CodeModule.CountOfLines
chTotal = chTotal + varLen
varLen = 0
Next
fPrint ""
fPrint "This Workbook has " & ctComponents & " Code Modules."
fPrint "This workbook has " & lnTotal & " lines of code and " & chTotal & " characters."
fPrint ""
'=========================================================
msg = "OPTION EXPLICIT TEST - if Option Explicit is not at the top of every code page, it encourages Logic Errors. If this area is blank, it is because the VBA Project is password protected for viewing, or that 'Trust Access to the VBA Project' is not checked in Macro Security."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
fPrint ""
For x = 1 To ActiveWorkbook.VBProject.VBComponents.Count
ver = ActiveWorkbook.VBProject.VBComponents(x).Name
' Debug.Print ver
optionTest = False
For y = 1 To ActiveWorkbook.VBProject.VBComponents(x).CodeModule.CountOfLines
var = ActiveWorkbook.VBProject.VBComponents(x).CodeModule.Lines(y, 1)
varLen = varLen + Len(var)
If InStr(1, var, "Option Explicit") > 0 Then
optionTest = True
Else: End If
Next
If (optionTest = False) And (varLen > 0) Then
fPrint ver & " does not have Variable Declaration Enforced"
Else
End If
Next
'=========================================================
msg = "VARIABLES...looking for names that might be reserved words, like COUNT, SHEET, ROW..etc. More is coming on that issue If this area is blank, it is because the VBA Project is password protected for viewing, or that 'Trust Access to the VBA Project' is not checked in Macro Security."
fPrint " "
fPrint msg
fPrint " "
fPrint ""
fPrint ""
' For x = 1 To ActiveWorkbook.VBProject.VBComponents.Count
' ver = ActiveWorkbook.VBProject.VBComponents(x).Name
' startType = False
'
' For y = 1 To ActiveWorkbook.VBProject.VBComponents(x).CodeModule.CountOfLines
' var = ActiveWorkbook.VBProject.VBComponents(x).CodeModule.Lines(y, 1)
' '-----------------------------------Variables and Functions----------------------
' If (InStr(1, var, "Dim") > 0) Or (InStr(1, var, "Private") > 0) Or (InStr(1, var, "Public") > 0) Or (InStr(1, var, "Function") > 0) Then
' fPrint ver & " : " & var
'
' End If
' '---------------------------Public and Private Types ----------------------------
' If (InStr(1, var, "Public Type") > 0) Or (InStr(1, var, "Private Type") > 0) Then
' startType = True
' 'fPrint "startType = True"
' End If
' '------------------------ End of Type
' If startType = True Then
' fPrint ver & " : " & var
' End If
'
' If (InStr(1, var, "End Type") > 0) Then startType = False
' 'fPrint "startType = False"
'
'
'
' Next
' Next
'=========================================================
msg = "OBJECT REFERENCES...looking for object references that are set and not set to Nothing. If this area is blank, it is because the VBA Project is password protected for viewing, or that 'Trust Access to the VBA Project' is not checked in Macro Security."
fPrint "-------------------------------------------------"
' fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
fPrint ""
For x = 1 To ActiveWorkbook.VBProject.VBComponents.Count
ver = ActiveWorkbook.VBProject.VBComponents(x).Name
'Debug.Print ver
For y = 1 To ActiveWorkbook.VBProject.VBComponents(x).CodeModule.CountOfLines
var = ActiveWorkbook.VBProject.VBComponents(x).CodeModule.Lines(y, 1)
If InStr(1, var, "Set") > 0 Then
' fPrint ver & " : " & var
Else: End If
Next
Next
'=========================================================
msg = "VBA REFERENCES...looking for VBA references. If this area is blank, it is because the VBA Project is password protected for viewing, or that 'Trust Access to the VBA Project' is not checked in Macro Security."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
For Each ref In ActiveWorkbook.VBProject.References
fPrint ref.Description & " : " & ref.FullPath
fPrint ref.Name & ":" & ref.GUID & ":" & ref.Major & ":" & ref.Minor
fPrint ""
'Debug.Print ref.Name & ":" & ref.GUID & ":" & ref.Major & ":" & ref.Minor
'Debug.Print ref.FullPath
'Debug.Print ref.Description
Next
'=========================================================
msg = "Count of Controls on Forms. Limit is If this area is blank, it is because the VBA Project is password protected for viewing, or that 'Trust Access to the VBA Project' is not checked in Macro Security."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "There can be a maximum of 254 different control names per form. A control array counts as one name. Every form that has more than 240 controls is displayed here"
fPrint "-form name-control name-top-left-Height-Width"
fPrint ""
On Error Resume Next
sp = " : "
For Each obj In ActiveWorkbook.VBProject.VBComponents
If obj.Type = 3 Then
Debug.Print obj.designer.Controls.Count
frmCount = obj.designer.Controls.Count
End If
On Error GoTo 0
If frmCount > 240 Then
fPrint obj.Name & " : " & frmCount & sp
End If
On Error Resume Next
For xx = 1 To frmCount
objTop = obj.designer.Controls(xx).Top
objLeft = obj.designer.Controls(xx).Left
objHeight = obj.designer.Controls(xx).Height
objWidth = obj.designer.Controls(xx).Width
If (objHeight = 0) Or (objWidth = 0) Then
badCount = badCount + 1
fPrint badCount & sp & " BAD!!!! " & obj.Name & sp & obj.designer.Controls(xx).Name & sp & objTop & sp & _
objLeft & sp & objHeight & sp & objWidth
'Stop
Else
' fPrint " " & obj.designer.Controls(xx).Name & sp & objTop & sp & _
objLeft & sp & objHeight & sp & objWidth
End If
Next
frmCount = 0
Next
'=========================================================
fPrint "-------------------------------------------------"
msg = "CUSTOM VIEWS - looking for Custom Views. Custom Views are created in a Shared Workbook for every user that Accesses the workbook. They can also be created manually, but this is not normally done."
fPrint msg
fPrint ""
fPrint "This Workbook has " & ActiveWorkbook.CustomViews.Count & " Custom Views."
fPrint ""
fPrint ""
For Each vw In ActiveWorkbook.CustomViews
fPrint vw.Name & sp & vw.PrintSettings & sp & vw.RowColSettings
Next
'=========================================================
msg = "Shared Users Left in File ...looking for more than one user. More than one user will indicate that the file crashed and left all the User Names in the file. It also tells when the user did this."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
fPrint ""
Set wb = ActiveWorkbook
us = wb.UserStatus
For x = 1 To UBound(us)
fPrint us(x, 1) & sp & us(x, 2)
Next
'=========================================================
msg = "Comments - Looking for unprintable characters, offensive words. Comments that are blank, or outside the normal Used Range."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
fPrint "Sheet Name : Comment Address : Comment Text"
For Each sht In ActiveWorkbook.Worksheets
sht.Select
For Each cmmt In sht.Comments
'Debug.Print sht.Name & sp & cmmt.Parent.Address & sp & cmmt.Text
commentCount = commentCount + 1
fPrint commentCount & sp & sht.Name & sp & cmmt.Parent.Address & sp & cmmt.Text
Next
Next
'=========================================================
msg = "Pivot Tables...more to be developed"
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
For Each sht In ActiveWorkbook.Worksheets
sht.Select
For x = 1 To sht.PivotTables.Count
'sht.Cells.Clear 'Uncomment this if you want to delete all Pivot Tables
Debug.Print sht.Name & " : " & sht.PivotTables(x).Name & " : " & sht.PivotTables(x).DataBodyRange.CurrentRegion.Address
fPrint sht.Name & " : " & sht.PivotTables(x).Name & " : " & sht.PivotTables(x).DataBodyRange.CurrentRegion.Address
Next
Next
'=========================================================
If printFormulas = vbYes Then
msg = "Cells with Errors - Look at all cells to determine why it has an Error Value. Only one cell per sheet is normal to keep the code length down."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
For Each sht In ActiveWorkbook.Worksheets
sht.Visible = True
sht.Select
ver = Cells.Find(What:="#", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
str1 = ActiveCell.Parent.Name & "|" & ActiveCell.Address
Do
ver = Cells.Find(What:="#", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Cells.FindNext(After:=ActiveCell).Activate
'Debug.Print ActiveCell.Address
'Debug.Print ActiveCell.Parent.Name
str2 = CStr(ActiveCell.Parent.Name & "|" & ActiveCell.Address)
'Debug.Print ver
cellError = cellError + 1
fPrint cellError & sp & str2
Loop Until str2 = str1
Next
'=========================================================
msg = "FORMULAS - List of all formulas, can be opened in Excel and Sorted."
fPrint "-------------------------------------------------"
fPrint msg
fPrint "-------------------------------------------------"
fPrint ""
For Each sht In ActiveWorkbook.Worksheets
sht.Visible = True
sht.Select
For Each cel In ActiveSheet.UsedRange
celFormula = cel.Formula
celValue = cel.Text
If InStr(1, celFormula, "=") > 0 Then
formulaCount = formulaCount + 1
fPrint formulaCount & sp & sht.Name & sp & cel.Address & sp & celValue & sp & celFormula
Else: End If
Next
Next
Else: End If
'=========================================================
fPrint "-------------------------------------------------"
msg = "Query Tables - List of all Query Tables and Type."
fPrint "-------------------------------------------------"
fPrint msg
fPrint ""
fPrint "Query Table Count : Sheet Name : Query Name : Query Destination : Query Type : Query Command Text"
fPrint ""
sp = " : "
For Each sht In ActiveWorkbook.Worksheets
For Each q In sht.QueryTables
qCount = qCount + 1
shtName = sht.Name
qName = q.Name
qDestination = q.Destination.Address(False, False)
qType = GetQueryType(q.QueryType)
qCommandText = GetCommandText(q)
'Debug.Print shtName & sp & qName & sp & qDestination & sp & qType & sp & qCommandText
fPrint qCount & sp & shtName & sp & qName & sp & qDestination & sp & qType & sp & qCommandText
fPrint ""
Next
Next
'=========================================================
fPrint "-------------------------------------------------"
'=========================================================
fPrint "-------------------------------------------------"
'=========================================================
fPrint "-------------------------------------------------"
Close
' MsgBox "You need to create a 'C:\Test' directory for this code to run. The Output file will be in 'C\Test' and will contain the name of the workbook."
' If Err.Number = 35021 Then fPrint "Missing VBA Reference" & " : " & ref.GUID
Application.EnableEvents = True
End Sub
Private Function GetQueryType(qt As XlQueryType) As String
Select Case qt
Case xlADORecordset
GetQueryType = "ADO recordset"
Case xlDAORecordset
GetQueryType = "DAO recordset"
Case xlODBCQuery
GetQueryType = "ODBC"
Case xlOLEDBQuery
GetQueryType = "OLE DB"
Case xlTextImport
GetQueryType = "Text File"
Case xlWebQuery
GetQueryType = "Web Query"
Case Else
GetQueryType = ""
End Select
End Function
Private Function GetCommandText(qt As QueryTable) As String
If qt.QueryType = xlWebQuery Or qt.QueryType = xlTextImport Or qt.QueryType = xlADORecordset Or qt.QueryType = xlDAORecordset Then
GetCommandText = ""
Else
GetCommandText = qt.CommandText
End If
End Function
Private Sub UnHideAllColumnsAndRows()
Dim sht As Worksheet
Application.ScreenUpdating = False
For Each sht In ActiveWorkbook.Sheets
On Error Resume Next
sht.Visible = True
sht.Cells.EntireColumn.Hidden = False
sht.Cells.EntireRow.Hidden = False
Next
On Error GoTo 0
End Sub
Sub cleanshape()
Dim shp As Shape
Dim sht As Worksheet
For Each sht In Sheets
For Each shp In sht.Shapes
If (shp.Height = 0) Or (shp.Width = 0) Then
shp.Delete
End If
Next
Next
End Sub