I changed the code for the footer of my PDF from .RightFooter = "Page &P of &N" to .CenterFooter = "Page &P of &N".
Now the "Page &P of &N" shows in the center and on the right even though the .RightFooter is no longer there.
I have deleted the Module and recreated it. I have restarted my PC thinking it was hung in memory.
Here's my code.
Sub Set_PrintRnag()
Dim LstRw As Long
Dim Rng As Range
Dim strDesktop As String
strDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
LstRw = Sheet2.Cells(Rows.Count, "R").End(xlUp).Row
Set Rng = Sheet2.Range("R1:S" & LstRw)
With Sheet2.PageSetup
.LeftHeader = "&C &B &20 Cohort List Report:" & Format(Date, "mm/dd/yyyy")
.CenterFooter = "Page &P of &N"
End With
Rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strDesktop & "\CohortList " & " " & Format(Date, "mm-dd-yyyy") & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
Found my own answer. Had to use .RightFooter = "".
Related
Believe me or not following code stops copying after first iteration! PLEASE HELP!
Even the NEW AI bot is unable to find issues with below code but for some reason my Excel (Microsoft 365 Latest) is struggling to go past first iteration?
Application.ScreenUpdating = False
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
Dim i As Integer
Dim ChkRange As String
Dim Path As String
Dim Path1 As String
Dim Path2 As String
Path1 = "G:\..."
Path2 = "C:\..."
If IsError(Path1) = True Then Path = Path2 Else Path = Path1
Sheets("P C").Select
If Range("J4").Value + 2 = Range("AD4").Value Then GoTo MsgBox
For i = 6 To 21
ChkRange = Range("R" & i).Value + Range("S" & i).Value + Range("T" & i).Value + Range("U" & i).Value + Range("V" & i).Value + Range("W" & i).Value + Range("X" & i).Value + Range("AA" & i).Value
If ChkRange = 0 Or Range("AE" & i).Value = Range("AB26").Value Then GoTo Nexti
Range("AE" & i).Copy
Sheets("Ps").Range("B6").PasteSpecial Paste:=xlPasteValues
If FSO.Folderexists(Path & Sheets("Ps").Range("B6").Value) = False Then
FSO.copyfolder Path & "Template", _
Path & Sheets("Ps").Range("B6").Value
End If
Sheets("E P").Range("A6:F1048576").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("'E P'!Criteria"), Unique:=False
Sheets(Array("E P", "Ps")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & Sheets("Ps").Range("B6").Value & "\Ps\" & Sheets("Ps").Range("K6").Value & ".pdf", OpenAfterPublish:=False
With Worksheets ("DATA")
.Unprotect
.Range("A1:AF1").Copy
.Range("A1").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Protect , DrawingObjects:=True, Contents:=True, Scenarios:=True
.Visible = False
End With
RDB_Mail_PDF_Outlook FileNamePDF:=Path & Sheets("Ps").Range("B6").Value & "\Ps\" & Sheets("Ps").Range("K6").Value & ".pdf", _
strTo:=Sheets("Ps").Range("K8").Value, _
strCc:="", _
strBcc:="", _
strSubject:="Re: Ps " & Sheets("Ps").Range("D13").Value, _
Signature:=True, _
Send:=True, _
strBody:="<Body style=font-size:11pt;font-family:Calibri>Hi " & Sheets("Ps").Range("C6").Value & ",<br><br>" & _
"Please find attached " & Sheets("Ps").Range("D13").Value & ".<br><br>" & _
"Let me know if you are having trouble viewing."
Nexti:
Next i
I even tried copying (manually) all data to new fresh spreadsheet... recode everything for hours to fail to debug!
I have unsuccessfully tried elimination process to debug.
Though I witnessed really weired bhaviours during the process of elimination I wouldnt mention it here as it will make no sense! At last after restarting PC I currently have consistant behaviour...
"Range("AE" & i).Copy
Sheets("Ps").Range("B6").PasteSpecial Paste:=xlPasteValues"
within For Loop will only work once, on second iteration it will copy some random number (198.166666666667) which forces the code to crash as it is not the expected value.
Ofcourse, I have checked all Ranges again especially AE6 to AE21.
Could someone sell me why I am getting a runtime error here?? I have almost this identical code in another project that works, and I cant figure out the issue.
Sub Create_PDF()
' Create and save .pdf
Dim pdfName As String
Dim myrange As String
myrange = Cells(Rows.Count, 6).End(xlUp).Address
Dim AccountNumber As String
AccountNumber = Right(A1, 3)
FullName = "P:\Public\Generated Letters\LTXN Export Spreadsheets\" & "AccountEnding" & AccountNumber & ".pdf"
'Sets the name and location for the new file
myrange = Cells(Rows.Count, 6).End(xlUp).Address
'sets the string end for the print area
With ActiveSheet.PageSetup
.PrintArea = "A1:" & myrange
.Orientation = xlLandscape
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
End With
'Setting the spreadsheet to print active content with columns fit to single page
If Dir(FullName) <> vbNullString Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="P:\Public\Generated_Letters\LTXN_Export_Spreadsheets\" & "AccountEnding" & AccountNumber & " - " & Format(Now, "mm.dd.yyyy hh mm") & ".pdf" _
, Quality:=xlQualityMedium, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="P:\Public\Generated_Letters\LTXN_Export_Spreadsheets\" & "AccountEnding" & AccountNumber & Format(Now, "mm.dd.yyyy hh mm") & ".pdf" _
, Quality:=xlQualityMedium, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
End If
'###This is where I am getting the runtime error and the file is not saving###
End Sub
Sub openFolder()
'Open the folder that we save the PDF to
Call Shell("explorer.exe" & " " & "P:\Public\Generated Letters\LTXN Export Spreadsheets\", vbNormalFocus)
End Sub
The one difference from the other project is that AccountNumber is a number and not text, but I figured in defining it as a string it shouldnt matter???
Try this:
Option Explicit
'use Const for fixed values
Const EXPORTS As String = "P:\Public\Generated Letters\LTXN Export Spreadsheets\"
Sub Create_PDF()
Dim ws As Worksheet, myRange As Range
Dim AccountNumber As String, dt As String, FullName As String, fName As String, sep As String
Set ws = ActiveSheet
AccountNumber = Right(ws.Range("A1").Value, 3) 'not just `A1`
With ActiveSheet.PageSetup
.PrintArea = "A1:" & ws.Cells(Rows.Count, 6).End(xlUp).Address
.Orientation = xlLandscape
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
End With
dt = Format(Now, "mm.dd.yyyy hh mm")
fName = EXPORTS & "AccountEnding" & AccountNumber
If Len(Dir(fName & ".pdf")) > 0 Then sep = " - "
fName = fName & sep & dt & ".pdf"
'note there's no `xlQualityMedium` enumeration for `Quality`
ws.ExportAsFixedFormat Type:=xlTypePDF, fileName:=fName, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
Sub openFolder()
'Folder paths with spaces need to be quoted....
Call Shell("explorer.exe" & " """ & EXPORTS & """", vbNormalFocus)
End Sub
Below is a bit of code I'm using to track changes to an excel doc. I get a runtime error '5' "Invalid procedure call or argument" on the bolded bit. I think the issue is the syntax or arguments for the Hyperlinks.Add anchor, since 'anchor' doesn't capitalize when I go to the next line. Do I have the arguments and the syntax correct?
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim sSheetName As String
sSheetName = "1107"
If ActiveSheet.Name <> "LogDetails" Then
Application.EnableEvents = False
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(1,0).Value = ActiveSheet.Name & " - " & Target.Address(0, 0)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = OldValue
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Target.Value
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Environ("username")
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Now
**Sheets("LogDetails").Hyperlinks.Add anchor:=Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", SubAddress:="'" & sSheetName & "'!" & OldAddress, TextToDisplay:=OldAddress**
Sheets("LogDetails").Columns("A:D").AutoFit
Application.EnableEvents = True
End If
End Sub
Consider removing the apostrophes when setting the SubAddress
Example recorded with Excel:
ActiveSheet.Hyperlinks.Add anchor:=Selection, Address:="", SubAddress:= _
"Sheet1!A1", TextToDisplay:="Sheet1!A1df"
Code
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
With Excel.Application
.EnableEvents = False
End With
Dim sSheetName As String
sSheetName = "1107"
If ActiveSheet.Name <> "LogDetails" Then
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name & " - " & Target.Address(0, 0)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = OldValue
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Target.Value
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Environ("username")
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Now
Dim hlink_cell As Range
Set hlink_cell = Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 5)
Sheets("LogDetails").Hyperlinks.Add anchor:=hlink_cell, Address:="", SubAddress:=sSheetName & "!" & OldAddress, TextToDisplay:=OldAddress
Sheets("LogDetails").Columns("A:D").AutoFit
End If
With Excel.Application
.EnableEvents = True
End With
End Sub
I am trying to send email to multiple person. But the email address that it should select is based on the user who has logged in. How do i do this? I have a table where I have 5 columns of email ID. Based on who is logged in, the code should go n select that person and send email to all the person in that row.
How do I achieve this? I know how to do in excel but access I am less aware. I am pasting both the codes I know and hv tried.
Sub Mail_ActiveSheet()
Dim OutApp As Object
Dim Outmail As Object
Dim sTo As String
Dim sCC As String
Dim lastrow, i As Integer
Dim sub1, sub2, sub3, body1 As Variant
Dim emailid, cc1, cc2, cc3, cc4, subj, attch, Sourcewb, Outnail, Soucrwb As Object
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
ThisWorkbook.Activate
'Code for Email sheet creation
Call EMAILSHEET_DATA
'Code for emailing schedular to the associates
Worksheets("Email_List").Select
lastrow = ThisWorkbook.Worksheets("Email_List").Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Set emailid = Worksheets("Email_List").Range("C" & i)
sTo = emailid
Set cc1 = Worksheets("Email_List").Range("D" & i)
'Set cc2 = Worksheets("Email_List").Range("E" & i)
'body1 = Worksheets("Email_List").Range("a" & i)
sCC = cc1 '& ";" & cc2
subj1 = Worksheets("Email_List").Range("F" & i).Value
subj2 = Worksheets("Email_List").Range("G" & i).Value
subj3 = Worksheets("Email_List").Range("H" & i).Value
subj = "Your Schedule for " & subj1 & subj2 & subj3
ActiveWorkbook.Activate
Set Sourcewb = ActiveWorkbook
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(0)
On Error Resume Next
With Outmail
.To = sTo
.CC = sCC
'.BCC=Sbcc
.Subject = subj
.Body = "Hello " & Worksheets("Email_List").Range("a" & i).Value & "," & vbCrLf & vbCrLf & subj & "." _
& vbCrLf & vbCrLf & Worksheets("Email_List").Range("i" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("j" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("k" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("l" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("m" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("n" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("o" & i).Value _
& vbCrLf & vbCrLf & "Note: Please report any scheduling conflicts or errors to your Supervisor." _
& vbCrLf & vbCrLf & "Thank You," & vbCrLf & "gmail.com Management"
.Send
End With
On Error GoTo 0
Set Outmail = Nothing
Set OutApp = Nothing
'ActiveWorkbook.Close False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Next i
ThisWorkbook.Activate
MsgBox ("Thank You! The Schedules have been sent to all the associates.")
End Sub
'DATA FOR EMAIL SHEET
Sub EMAILSHEET_DATA()
Worksheets("Email_list").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Worksheets("Schedules").Select
Range("B15").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Email_List").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,4,0)"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,3,0)"
Range("D2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,4,0)"
Range("E2").Select
'ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],Associate_Info!C[-4]:C[-1],4,0)"
ActiveCell.FormulaR1C1 = "Information not available"
Range("F2").Select
ActiveCell.FormulaR1C1 = "=Schedules!R12C5"
Range("G2").Select
ActiveCell.FormulaR1C1 = " to "
Range("H2").Select
ActiveCell.FormulaR1C1 = "=Schedules!R12C17"
Range("I2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C5,""MM/DD/YY"") & "" , "" & Schedules!R13C5 & "" , "" & Schedules!R[13]C[-4] & "" - "" & Schedules!R[13]C[-3]"
Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C7,""MM/DD/YY"") & "" , "" & Schedules!R13C7 & "" , "" & Schedules!R[13]C[-3] & "" - "" & Schedules!R[13]C[-2]"
Range("K2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C9,""MM/DD/YY"") & "" , "" & Schedules!R13C9 & "" , "" & Schedules!R[13]C[-2] & "" - "" & Schedules!R[13]C[-1]"
Range("L2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C11,""MM/DD/YY"") & "" , "" & Schedules!R13C11 & "" , "" & Schedules!R[13]C[-1] & "" - "" & Schedules!R[13]C[0]"
Range("M2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C13,""MM/DD/YY"") & "" , "" & Schedules!R13C13 & "" , "" & Schedules!R[13]C & "" - "" & Schedules!R[13]C[1]"
Range("N2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C15,""MM/DD/YY"") & "" , "" & Schedules!R13C15 & "" , "" & Schedules!R[13]C[1] & "" - "" & Schedules!R[13]C[2]"
Range("O2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C17,""MM/DD/YY"") & "" , "" & Schedules!R13C17 & "" , "" & Schedules!R[13]C[2] & "" - "" & Schedules!R[13]C[3]"
Range("O2").Select
Selection.End(xlToLeft).Select
Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Range("A2").Select
lastrow = Cells(2, 1).End(xlDown).Row
'Range("B2:O" & lastrow).Select
Range("b3:o" & lastrow).Select
'Range("B3:B571").Select
'Range("B571").Activate
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.End(xlUp).Select
Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.End(xlUp).Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("$A$1:$O$291").AutoFilter Field:=2, Criteria1:="#N/A"
Rows("6:6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter
Range("A1").Select
ActiveWorkbook.Save
End Sub
Public Sub EmailList()
'late Binding
Dim olApp As Object
Dim olemail As Object
Dim strbody As String
'creating new outlook instance
Set olApp = CreateObject("Outlook.Application")
Set olemail = olApp.CreateItem(0)
strbody = "<html> <body> Hi " & Me.FullName & " <br/> <br/> Your leaves have been saved. <br/> Start Date: " & Me.Text8 & " <br/> End Date: " & Me.Text10 & " <br/> <br/> Regards <br/> Walmart.com Management "
Set olApp = CreateObject("Outlook.Application")
Set olemail = olApp.CreateItem(0)
With olemail
.BodyFormat = 2
.Display
.htmlBody = strbody
.to = "reetika.choudhary#gmail.com"
.Subject = "Leaves Applied"
.Send
DoCmd.SetWarnings WarningsOff
End With
End Sub
excel code is as below:
Any help will be highly appreciated! Thanks in advance.
You can use Environ("USERNAME") on a windows system to pull the username from the environment variables:
Sub SO()
Dim username As String
username = Environ("USERNAME")
MsgBox username & " is currently logged on."
End Sub
Updated Code: (Macro doesn't run)
Dim objExcel, objWorkbook, xlModule, strCode
If ReportFileStatus("C:\scripts\test1.xls") = "True" Then
OpenFile "C:\scripts\test1.xls", "C:\scripts\test.xls"
End If
If ReportFileStatus("C:\scripts\test2.xls") = "True" Then
OpenFile "C:\scripts\test2.xls", "C:\scripts\test1.xls"
End If
On Error Resume Next
Set xlModule = Nothing
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing
On Error GoTo 0
'~~> Sub to open the file
Sub OpenFile(sFile, DestFile)
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(sFile)
Set xlModule = objWorkbook.VBProject.VBComponents.Add(1)
strCode = _
"Sub CreateFile()" & vbCr & _
" Columns(""A:A"").Select" & vbCr & _
" Selection.Delete Shift:=xlToLeft" & vbCr & _
" Rows(""1:8"").Select" & vbCr & _
" Selection.Delete Shift:=xlUp" & vbCr & _
" Columns(""E:E"").Select" & vbCr & _
" Selection.ClearContents" & vbCr & _
"FName = ActiveWorkbook.Name" & vbCr & _
"If Right(FName, 4) = "".xls"" Then" & vbCr & _
"FName = Mid(FName, 1, Len(FName) - 4)" & vbCr & _
"End If" & vbCr & _
"Columns(1).Insert Shift:=xlToRight" & vbCr & _
"For i = 1 To Range(""B65000"").End(xlUp).Row" & vbCr & _
"TempString = """ & vbCr & _
"For j = 2 To Range(""HA1"").End(xlToLeft).Column" & vbCr & _
"If j <> Range(""HA1"").End(xlToLeft).Column Then" & vbCr & _
"TempString = TempString & _" & vbCr & _
"Cells(i, j).Value & ""^""" & vbCr & _
"Else" & vbCr & _
"TempString = TempString & _" & vbCr & _
"Cells(i, j).Value" & vbCr & _
"End If" & vbCr & _
"Next" & vbCr & _
"Cells(i, 1).Value = TempString" & vbCr & _
"Next" & vbCr & _
"Columns(1).Select" & vbCr & _
"Selection.Copy" & vbCr & _
"Workbooks.Add" & vbCr & _
"Range(""A1"").Select" & vbCr & _
"ActiveSheet.Paste" & vbCr & _
"Application.CutCopyMode = False" & vbCr & _
" ChDir ""C:\RES_BILLING\Export""" & vbCr & _
" ActiveWorkbook.SaveAs Filename:=FName & "".txt"", FileFormat:=xlTextPrinter, Local:=True, CreateBackup:=False" & vbCr & _
" Application.WindowState = xlMinimized" & vbCr & _
" Application.WindowState = xlNormal" & vbCr & _
" Application.DisplayAlerts = False" & vbCr & _
"End Sub"
xlModule.CodeModule.AddFromString strCode
objWorkbook.Close (False)
End Sub
'~~> Function to check if file exists
Function ReportFileStatus(filespec)
Dim fso, msg
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists(filespec)) Then
msg = "True"
Else
msg = "False"
End If
ReportFileStatus = msg
End Function
Original Question:
My goal is to have a VB Script run a macro in multiple excel spreadsheets.
This works great but I have one issue.
Sometimes a worksheet may not be available for a given month, this is intentional.
I would like to create an IF Statement that says if excel file is unavailable skip to next file.
So in this situation, if test1.xls is unavailable move one to the next file. I Hope that make sense. Thank you to anyone who can guide me in the right direction. Programming is not my forte.
Further to my comments why not check if the file exists or not before opening it? Also why not create one procedure to open the file instead of duplicating it?
Try this (TRIED AND TESTED)
Dim objExcel, objWorkbook, xlModule, strCode
If ReportFileStatus("C:\scripts\test1.xls") = "True" Then
OpenFile "C:\scripts\test1.xls", "C:\scripts\test.xls"
End If
If ReportFileStatus("C:\scripts\test2.xls") = "True" Then
OpenFile "C:\scripts\test2.xls", "C:\scripts\test1.xls"
End If
On Error Resume Next
Set xlModule = Nothing
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing
On Error GoTo 0
'~~> Sub to open the file
Sub OpenFile(sFile, DestFile)
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(sFile)
Set xlModule = objWorkbook.VBProject.VBComponents.Add(1)
strCode = _
"sub test()" & vbCr & _
" msgbox ""Inside the macro"" " & vbCr & _
"end sub"
xlModule.CodeModule.AddFromString strCode
objWorkbook.SaveAs DestFile
objExcel.Run "Test"
objWorkbook.Close (False) '<~~ Change false to true in case you want to save changes
End Sub
'~~> Function to check if file exists
Function ReportFileStatus(filespec)
Dim fso, msg
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists(filespec)) Then
msg = "True"
Else
msg = "False"
End If
ReportFileStatus = msg
End Function
TRIED AND TESTED
Dim objExcel
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.DisplayAlerts = False
InsertCode "C:\scripts\test1.xls", "C:\scripts\test1_upd.xls"
InsertCode "C:\scripts\test2.xls", "C:\scripts\test2_upd.xls"
objExcel.Quit
Sub InsertCode(wbPath, newPath)
Dim objWorkbook, xlmodule, strCode
On Error Resume Next
Set objWorkbook = objExcel.Workbooks.Open(wbPath)
On Error GoTo 0
If Not objWorkbook Is Nothing Then
Set xlmodule = objWorkbook.VBProject.VBComponents.Add(1)
strCode = _
"sub test()" & vbCr & _
" msgbox ""Inside the macro"" " & vbCr & _
"end sub"
xlmodule.CodeModule.AddFromString strCode
objWorkbook.SaveAs newPath
objWorkbook.Close
End If
End Sub