none
xlsm migration RRS feed

  • Question

  • Hi All

    I've been given a 'wssi'(?) application to migrate. In essence its a folder in a shared-location containing hundreds of 'xlsm' spreadsheets in sub-folders.

    My task is to open them one-by-one, press alt-f11, navigate down the tree in the top-left pane, opening MODULES then CONSTANTS.

    Then I need to change the hard-coded values EG: Public Const DB_SERVER As string = "Old-Name"

    and type in the "New-Name" before saving.

    Please, please tell me there is a quicker way ... or I'll be at it for a weeks.

    Richard


    Tuesday, December 9, 2014 5:24 PM

Answers

  • Be sure your security settings allows macros to access the VBA project object model, otherwise the code below fails.

    Andreas.

    Option Explicit
    
    Sub Test()
      Dim Path As String, FName As String
      Dim SearchFor As String, ReplaceWith As String, Contents As String
      Dim Wb As Excel.Workbook
      Dim vbComp As Object 'VBIDE.VBComponent
      Dim Changed As Boolean
      
      'Customize this:
      Path = "C:\Users\Killer\Documents\"
      SearchFor = "Const DB_Server = ""old_name"""
      ReplaceWith = "Const DB_Server = ""new_name"""
      
      'Prepare Excel
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual
      Application.ScreenUpdating = False
      Application.DisplayAlerts = False
      
      'Find the first file
      FName = Dir(Path & "*.xlsm")
      'While found
      Do While FName <> ""
        'Open the file
        Set Wb = Workbooks.Open(Path & FName, False, False)
        Changed = False
        'For each module
        For Each vbComp In Wb.VBProject.VBComponents
          With vbComp.CodeModule
            'Any lines?
            If .CountOfLines > 0 Then
              'Get them
              Contents = .Lines(1, .CountOfLines)
              If InStr(1, Contents, SearchFor, vbTextCompare) > 0 Then
                Contents = Replace(Contents, SearchFor, ReplaceWith, , , vbTextCompare)
                'Replace the contents with the modified string
                .DeleteLines 1, .CountOfLines
                .InsertLines 1, Contents
                'Clean empty lines at the top and bottom
                Do While Len(Trim$(.Lines(1, 1))) = 0
                  .DeleteLines 1, 1
                Loop
                Do While Len(Trim$(.Lines(.CountOfLines, 1))) = 0
                  .DeleteLines .CountOfLines, 1
                Loop
                Changed = True
              End If
            End If
          End With
        Next
        'Close the file, save if necessary
        Wb.Close Changed
        'Next file
        FName = Dir
      Loop
      
      'Done
      Application.EnableEvents = True
      Application.Calculation = xlCalculationAutomatic
      Application.ScreenUpdating = True
      Application.DisplayAlerts = True
    End Sub

    Wednesday, December 10, 2014 8:04 AM

All replies

  • Be sure your security settings allows macros to access the VBA project object model, otherwise the code below fails.

    Andreas.

    Option Explicit
    
    Sub Test()
      Dim Path As String, FName As String
      Dim SearchFor As String, ReplaceWith As String, Contents As String
      Dim Wb As Excel.Workbook
      Dim vbComp As Object 'VBIDE.VBComponent
      Dim Changed As Boolean
      
      'Customize this:
      Path = "C:\Users\Killer\Documents\"
      SearchFor = "Const DB_Server = ""old_name"""
      ReplaceWith = "Const DB_Server = ""new_name"""
      
      'Prepare Excel
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual
      Application.ScreenUpdating = False
      Application.DisplayAlerts = False
      
      'Find the first file
      FName = Dir(Path & "*.xlsm")
      'While found
      Do While FName <> ""
        'Open the file
        Set Wb = Workbooks.Open(Path & FName, False, False)
        Changed = False
        'For each module
        For Each vbComp In Wb.VBProject.VBComponents
          With vbComp.CodeModule
            'Any lines?
            If .CountOfLines > 0 Then
              'Get them
              Contents = .Lines(1, .CountOfLines)
              If InStr(1, Contents, SearchFor, vbTextCompare) > 0 Then
                Contents = Replace(Contents, SearchFor, ReplaceWith, , , vbTextCompare)
                'Replace the contents with the modified string
                .DeleteLines 1, .CountOfLines
                .InsertLines 1, Contents
                'Clean empty lines at the top and bottom
                Do While Len(Trim$(.Lines(1, 1))) = 0
                  .DeleteLines 1, 1
                Loop
                Do While Len(Trim$(.Lines(.CountOfLines, 1))) = 0
                  .DeleteLines .CountOfLines, 1
                Loop
                Changed = True
              End If
            End If
          End With
        Next
        'Close the file, save if necessary
        Wb.Close Changed
        'Next file
        FName = Dir
      Loop
      
      'Done
      Application.EnableEvents = True
      Application.Calculation = xlCalculationAutomatic
      Application.ScreenUpdating = True
      Application.DisplayAlerts = True
    End Sub

    Wednesday, December 10, 2014 8:04 AM
  • thank you thank you Andreas
    Wednesday, December 10, 2014 10:19 AM