Sub CopyModulesToSheet()
Dim ws As Worksheet
Dim vbComp As Object
Dim codeText As String
Dim i As Long
Dim row As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.Range("A:B").ClearContents
row = 1
For Each vbComp In ThisWorkbook.VBProject.VBComponents
If vbComp.Type = 1 Then   ' Standard modules only
codeText = vbComp.CodeModule.Lines(1, vbComp.CodeModule.CountOfLines)
ws.Cells(row, 1).Value = vbComp.Name
ws.Cells(row, 2).Value = codeText
row = row + 1
End If
Next vbComp
MsgBox "Modules copied to Sheet1."
End Sub
'
'---------------------------------------------------------------------
Sub ReplaceModulesFromSheet()
Dim ws As Worksheet
Dim vbComp As Object
Dim moduleName As String
Dim moduleCode As String
Dim newComp As Object
Dim row As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
row = 1
Application.ScreenUpdating = False
Do While ws.Cells(row, 1).Value <> ""
moduleName = ws.Cells(row, 1).Value
moduleCode = ws.Cells(row, 2).Value
' SAFETY CHECK GOES RIGHT HERE
If Trim(moduleCode) = "" Then
MsgBox "Blank code found for module: " & moduleName, vbCritical
Exit Sub
End If
' Delete old module if it exists
On Error Resume Next
Set vbComp = ThisWorkbook.VBProject.VBComponents(moduleName)
If Not vbComp Is Nothing Then
ThisWorkbook.VBProject.VBComponents.Remove vbComp
End If
On Error GoTo 0
' Add new module
Set newComp = ThisWorkbook.VBProject.VBComponents.Add(1)
newComp.Name = moduleName
' Insert edited code
newComp.CodeModule.AddFromString moduleCode
row = row + 1
Loop
Application.ScreenUpdating = True
MsgBox "Modules replaced successfully."
End Sub
'
'---------------------------------------------------------------------
Sub ShortenProcedureNamesTo28()
' Shorten + mark duplicates
Dim vbComp As Object
Dim cm As CodeModule
Dim procName As String
Dim shortName As String
Dim dict As Object
Dim lineNum As Long
Dim ws As Worksheet
Dim row As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.Range("A:D").ClearContents
ws.Range("A1").Value = "Original"
ws.Range("B1").Value = "Shortened"
ws.Range("C1").Value = "Module"
ws.Range("D1").Value = "Status"
Set dict = CreateObject("Scripting.Dictionary")
row = 2
For Each vbComp In ThisWorkbook.VBProject.VBComponents
Set cm = vbComp.CodeModule
lineNum = 1
Do While lineNum < cm.CountOfLines
procName = cm.ProcOfLine(lineNum, vbext_pk_Proc)
If procName <> "" Then
shortName = Left(procName, 28)
If dict.Exists(shortName) Then
ws.Cells(row, 4).Value = "DUPLICATE"
Else
dict.Add shortName, True
ws.Cells(row, 4).Value = "OK"
End If
ws.Cells(row, 1).Value = procName
ws.Cells(row, 2).Value = shortName
ws.Cells(row, 3).Value = vbComp.Name
row = row + 1
lineNum = cm.ProcStartLine(procName, vbext_pk_Proc) + _
cm.ProcCountLines(procName, vbext_pk_Proc)
Else
lineNum = lineNum + 1
End If
Loop
Next vbComp
MsgBox "Procedure names shortened and checked for duplicates."
End Sub
'
'---------------------------------------------------------------------
Sub FixShortNameDuplicates()
' Fix duplicates with suffixes
Dim ws As Worksheet
Dim dict As Object
Dim baseName As String
Dim newName As String
Dim row As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set dict = CreateObject("Scripting.Dictionary")
row = 2
Do While ws.Cells(row, 1).Value <> ""
baseName = ws.Cells(row, 2).Value
If Not dict.Exists(baseName) Then
dict.Add baseName, 1
ws.Cells(row, 2).Value = baseName
Else
dict(baseName) = dict(baseName) + 1
newName = baseName & "_" & dict(baseName)
ws.Cells(row, 2).Value = newName
End If
row = row + 1
Loop
MsgBox "Duplicates fixed with numeric suffixes."
End Sub
'
'---------------------------------------------------------------------
Sub RenameMacroEverywhere(oldName As String, newName As String)
' Rename everywhere (you already have this, but here it is clean)
Dim vbComp As Object
Dim cm As CodeModule
Dim totalLines As Long
Dim i As Long
Dim lineText As String
For Each vbComp In ThisWorkbook.VBProject.VBComponents
Set cm = vbComp.CodeModule
totalLines = cm.CountOfLines
For i = 1 To totalLines
lineText = cm.Lines(i, 1)
If InStr(1, lineText, oldName, vbTextCompare) > 0 Then
lineText = Replace(lineText, oldName, newName, , , vbTextCompare)
cm.ReplaceLine i, lineText
End If
Next i
Next vbComp
End Sub
'
'---------------------------------------------------------------------
Sub ApplyRenamesFromSheet()
' Driver to apply renames from Sheet1
Dim ws As Worksheet
Dim row As Long
Dim oldName As String
Dim newName As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
row = 2
Do While ws.Cells(row, 1).Value <> ""
oldName = ws.Cells(row, 1).Value
newName = ws.Cells(row, 2).Value
If oldName <> newName Then
RenameMacroEverywhere oldName, newName
End If
row = row + 1
Loop
MsgBox "Renames applied."
End Sub
'