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