ChangeCode

[Bomba]

Hi,
In module1 I have this code:

Code: Select all

Sub SO()
    Dim strPath As String
    strPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")

dateStamp = Date

If Not Range("Q1").Value = dateStamp Then
    Range("Q1").Value = dateStamp
'// replace with your code below-------------
Workbooks("2.xlsm").Sheets("Chit1&2").Range("E20:H21").Value = "=" & "'" & strPath & "\My System\2. February 2019\[1.xlsm]Chit1&2'!E20:H21"
Workbooks("2.xlsm").Sheets("Chit3&4").Range("E20:H21").Value = "=" & "'" & strPath & "\My System\2. February 2019\[1.xlsm]Chit3&4'!E20:H21"
Workbooks("2.xlsm").Sheets("Chit5&6").Range("E20:H21").Value = "=" & "'" & strPath & "\My System\2. February 2019\[1.xlsm]Chit5&6'!E20:H21"
Workbooks("2.xlsm").Sheets("Chit1&2").Cells(8, "J").Value = "=" & "'" & strPath & "\My System\2. February 2019\[1.xlsm]Chit1&2'!J8"
Workbooks("2.xlsm").Sheets("Chit3&4").Cells(8, "J").Value = "=" & "'" & strPath & "\My System\2. February 2019\[1.xlsm]Chit3&4'!J8"
Workbooks("2.xlsm").Sheets("Chit5&6").Cells(8, "J").Value = "=" & "'" & strPath & "\My System\2. February 2019\[1.xlsm]Chit5&6'!J8"
    MsgBox "Code run for first time today!"
Else
    MsgBox "Code has already been run today!"
End If

End Sub

I am trying to replace "2. February 2019" to "3. March 2019" from workbook 2 to 31. I used this code (below) but after I run it, an error appeared and after debug the line (With wbk.VBProject.VBComponents("Module1").CodeModule) becomes highlighted. This is the code that I used:

Code: Select all

Sub ChangeCode()
    Dim strPath As String
    Dim strFolder As String
    Dim i As Long
    Dim wbk As Workbook
    Dim lngSO As Long
    Dim lngCount As Long
    Dim strLines As String
    Application.ScreenUpdating = False
    strPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    strFolder = strPath & "\My System\3. March 2019\"
    For i = 2 To 31
        Set wbk = Workbooks.Open(strFolder & i & ".xlsm")
        With wbk.VBProject.VBComponents("Module1").CodeModule
            lngSO = .ProcBodyLine("SO", 0) ' 0=vbext_pk_Proc
            lngCount = .ProcCountLines("SO", 0)
            .InsertLines lngSO + 1, "    Dim strPath As String" & vbCrLf & _
                "    strPath = CreateObject(""WScript.Shell"").SpecialFolders(""Desktop"")"
            strLines = .Lines(lngSO, lngCount)
            .DeleteLines lngSO, lngCount
            strLines = Replace(strLines, "\My System\2. February 2019\", "\My System\3. March 2019\")
            .InsertLines lngSO, strLines
        End With
        wbk.Close SaveChanges:=True
    Next i
    Application.ScreenUpdating = True
End Sub

Thanks in advance

[HansV]

If the error is Run-time error '9': Subscript out of range, it means that the name Module1 is not correct. Check the workbook!

[Bomba]

Master I remembered that about a year ago I asked you something like this and I found it. One has to put the file with the code in the same folder of the other files and one has to tick the "Trust access to the VBA project object model" check box.
I used this code:

Code: Select all

Sub ReplaceText()
    Const OldText = "My System\2. February 2019"
    Const NewText = "My System\3. March 2019"
    Dim Folder As String
    Dim File As String
    Dim Wbk As Workbook
    Dim NumLines As Long
    Dim Lines As String
    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            Folder = .SelectedItems(1)
        Else
            MsgBox "You didn't select a folder!", vbExclamation
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    Folder = Folder & "\"
    File = Dir(Folder & "*.xlsm")
    Do While File <> ""
        If UCase(File) <> UCase(ThisWorkbook.Name) Then
            Set Wbk = Workbooks.Open(Folder & File)
            With Wbk.VBProject.VBComponents("Module1").CodeModule
                NumLines = .CountOfLines
                Lines = .Lines(1, NumLines)
                Lines = Replace(Lines, OldText, NewText)
                .DeleteLines 1, NumLines
                .AddFromString Lines
            End With
            Wbk.Close SaveChanges:=True
        End If
        File = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Thanks

[HansV]

Ah - I didn't think of that. Good that you found it.