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

'=========================================================

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

'=========================================================

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

'=========================================================

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

'=========================================================

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

shpCount = 0

'=========================================================

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

'=========================================================

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))

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))

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)

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

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 ""

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

If (optionTest = False) And (varLen > 0) Then

fPrint ver & " does not have Variable Declaration Enforced"

Else

End If

'=========================================================

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 ""

' 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

'=========================================================

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 ""

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

'=========================================================

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

'=========================================================

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

frmCount = 0

'=========================================================

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 ""

For Each vw In ActiveWorkbook.CustomViews

fPrint vw.Name & sp & vw.PrintSettings & sp & vw.RowColSettings

'=========================================================

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 ""

Set wb = ActiveWorkbook

us = wb.UserStatus

For x = 1 To UBound(us)

fPrint us(x, 1) & sp & us(x, 2)

'=========================================================

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

'=========================================================

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

'=========================================================

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

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

'=========================================================

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

'=========================================================

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 ""

'=========================================================

fPrint "-------------------------------------------------"

'=========================================================

fPrint "-------------------------------------------------"

'=========================================================

fPrint "-------------------------------------------------"

' 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

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

End Sub