Reputation: 59
I'm a newbie. I discovered Copilot and used it to get the code below. I want to track the number of characters in all objects to keep watch of excessive code, etc. The code lists the Module Name in column 1 and the number of characters in column 2. It works beautifully with one important exception; 1 of the 9 worksheets and 2 of the 9 Userforms are not appearing on the list. The weakness of Copilot is it often can only take you so far. Any idea what's up? Thank you in advance.
Option Explicit
Sub CheckModuleLength()
Dim ws As Worksheet
Dim tbl As ListObject
' Reference the Legend worksheet
Set ws = ThisWorkbook.Worksheets("Legend")
' Create or reference the table
Set tbl = ws.ListObjects("tblModCharCount")
On Error GoTo 0
If tbl Is Nothing Then
' Create a new table if it doesn't exist
Set tbl = ws.ListObjects.Add(xlSrcRange, ws.Range("AA2:AB2"), , xlYes)
tbl.Name = "tblModCharCount"
tbl.HeaderRowRange(1).Value = "Module Name"
tbl.HeaderRowRange(2).Value = "Character Count"
Else
' Clear existing table data without changing the style
If tbl.ListRows.Count > 0 Then tbl.DataBodyRange.Delete
End If
' Add ThisWorkbook as its own group
AddThisWorkbook ws, tbl
' Organize the output by categories
WriteModuleLengths ws, tbl, vbext_ct_Document, "Worksheets"
WriteModuleLengths ws, tbl, vbext_ct_MSForm, "UserForms"
WriteModuleLengths ws, tbl, vbext_ct_StdModule, "Modules"
WriteModuleLengths ws, tbl, vbext_ct_ClassModule, "Class Modules"
' Add overall total at the bottom
AddOverallTotal ws, tbl
End Sub
Sub AddThisWorkbook(ws As Worksheet, tbl As ListObject)
Dim vbComp As VBComponent
Dim codeLines As Long
Dim charCount As Long
Dim moduleCode As String
Dim row As ListRow
' Find ThisWorkbook component
For Each vbComp In ThisWorkbook.VBProject.VBComponents
If vbComp.Name = "ThisWorkbook" Then
codeLines = vbComp.CodeModule.CountOfLines
If codeLines > 0 Then
moduleCode = vbComp.CodeModule.Lines(1, codeLines)
charCount = Len(moduleCode)
' Write ThisWorkbook to the table
Set row = tbl.ListRows.Add
row.Range(1).Value = "ThisWorkbook"
row.Range(2).Value = charCount
End If
Exit For
End If
Next vbComp
End Sub
Sub WriteModuleLengths(ws As Worksheet, tbl As ListObject, moduleType As VBIDE.vbext_ComponentType, category As String)
Dim vbComp As VBComponent
Dim codeLines As Long
Dim charCount As Long
Dim moduleCode As String
Dim row As ListRow
Dim moduleCount As Long
Dim moduleNames() As String
Dim charCounts() As Long
Dim i As Long
Dim processedComponents As Collection
Set processedComponents = New Collection
moduleCount = 0
ReDim moduleNames(1 To 1)
ReDim charCounts(1 To 1)
' Collect module names and character counts
For Each vbComp In ThisWorkbook.VBProject.VBComponents
On Error Resume Next
processedComponents.Add vbComp.Name, vbComp.Name
If Err.Number = 0 Then
If vbComp.Type = moduleType And vbComp.Name <> "ThisWorkbook" Then
codeLines = vbComp.CodeModule.CountOfLines
If codeLines > 0 Then
moduleCode = vbComp.CodeModule.Lines(1, codeLines)
charCount = Len(moduleCode)
moduleCount = moduleCount + 1
ReDim Preserve moduleNames(1 To moduleCount)
ReDim Preserve charCounts(1 To moduleCount)
moduleNames(moduleCount) = vbComp.Name
charCounts(moduleCount) = charCount
End If
End If
End If
On Error GoTo 0
Next vbComp
' Sort the module names alphabetically
Call BubbleSort(moduleNames, charCounts)
' Write the result to the table
For i = 1 To moduleCount
Set row = tbl.ListRows.Add
row.Range(1).Font.Bold = False
row.Range(2).Font.Bold = False
row.Range(1).Value = moduleNames(i)
row.Range(2).Value = charCounts(i)
Next i
' Add subtotal for the category
Set row = tbl.ListRows.Add
row.Range(1).Value = "Total: " & moduleCount & " " & category
row.Range(2).Value = ""
row.Range.Font.Bold = True
End Sub
Sub AddOverallTotal(ws As Worksheet, tbl As ListObject)
Dim totalModules As Long
Dim row As ListRow
totalModules = tbl.ListRows.Count
' Add overall total at the bottom
Set row = tbl.ListRows.Add
row.Range(1).Value = "Overall Total: " & totalModules & " Modules"
row.Range(2).Value = ""
row.Range.Font.Bold = True
End Sub
Sub BubbleSort(arr1() As String, arr2() As Long)
Dim i As Long, j As Long
Dim temp1 As String
Dim temp2 As Long
For i = LBound(arr1) To UBound(arr1) - 1
For j = i + 1 To UBound(arr1)
If LCase(arr1(i)) > LCase(arr1(j)) Then
' Swap arr1
temp1 = arr1(i)
arr1(i) = arr1(j)
arr1(j) = temp1
' Swap arr2
temp2 = arr2(i)
arr2(i) = arr2(j)
arr2(j) = temp2
End If
Next j
Next i
End Sub
Upvotes: 0
Views: 13