VB Script If Statement - Opening Excel Workbook - excel

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

Related

How can I save an Excel sheet as a PDF to two different locations at once?

I am trying to get this VBA macro to save the selection from an Excel sheet as a PDF but in two different locations. The reason is part of the company seems to use OneDrive as their default directory and the other uses their local drive. So when I have the export as C:\Users\xxxx\Desktop, it will do that, but it won't appear on Desktops of those who use OneDrive. So I figured I'd code it up to where it saves in both directories so no matter what they use, it's on their actual Desktop. However, when I get to the second save location, it triggers the following error: Run-Time error '1004': Application-defined or object defined error
Sub gpSaveSend()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String, signature As String
Dim PdfFile2 As String
Dim OutlApp As Object
Dim RngCopied As Range
Dim StrName As String
Dim strCheck As String
Dim strCheck2 As String
Dim StrPath As String
Dim StrPath2 As String
Dim StrFullPath As String
Dim StrFullPath2 As String
Set RngCopied = Selection
Title = Range("A1")
MyDate = Format(Date, "MM-DD-YYYY")
ActiveWorkbook.Save
With ThisWorkbook
StrPath = Environ("USERPROFILE") & "\OneDrive - xxx \" & "Desktop\"
StrName = ActiveSheet.Range("AA40")
StrName2 = ActiveSheet.Range("AA34")
StrName3 = ActiveSheet.Range("AA33")
StrName4 = ActiveSheet.Range("AA38")
PdfFile = StrPath & ActiveSheet.Range("AA40") & "\" & ActiveSheet.Range("AA34") & "\" & ActiveSheet.Range("AA33") & "\" & Year(Date) & "\" & Format(Date, "mmmm") & "\" & ActiveSheet.Range("AA38") & "\" & ActiveSheet.Range("AA33") & " - " & ActiveSheet.Range("AA38") & " - " & MyDate & ".pdf"
PdfFile2 = StrPath2 & ActiveSheet.Range("AA40") & "\" & ActiveSheet.Range("AA34") & "\" & ActiveSheet.Range("AA33") & "\" & Year(Date) & "\" & Format(Date, "mmmm") & "\" & ActiveSheet.Range("AA38") & "\" & ActiveSheet.Range("AA33") & " - " & ActiveSheet.Range("AA38") & " - " & MyDate & ".pdf"
StrFullPath = StrPath & "\" & StrName & "\" & PdfFile
StrFullPath2 = StrPath2 & "\" & StrName & "\" & PdfFile2
strCheck = StrPath & "\" & StrName
FolderCheck (strCheck)
strCheck = strCheck & "\" & StrName2
FolderCheck (strCheck)
strCheck = strCheck & "\" & StrName3
FolderCheck (strCheck)
strCheck = strCheck & "\" & Year(Date)
YearFolderCheck (strCheck)
strCheck = strCheck & "\" & Format(Date, "mmmm")
YearFolderCheck (strCheck)
strCheck = strCheck & "\" & StrName4
YearFolderCheck (strCheck)
End With
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.Zoom = False
End With
Sheets("Form").Range("A1:K91").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
With ThisWorkbook
StrPath2 = Environ("USERPROFILE") & "\Desktop\"
PdfFile2 = StrPath2 & ActiveSheet.Range("AA40") & "\" & ActiveSheet.Range("AA34") & "\" & ActiveSheet.Range("AA33") & "\" & Year(Date) & "\" & Format(Date, "mmmm") & "\" & ActiveSheet.Range("AA38") & "\" & ActiveSheet.Range("AA33") & " - " & ActiveSheet.Range("AA38") & " - " & MyDate & ".pdf"
StrFullPath2 = StrPath2 & "\" & StrName & "\" & PdfFile2
strCheck2 = StrPath2 & "\" & StrName
FolderCheck2 (strCheck2)
strCheck2 = strCheck2 & "\" & StrName2
FolderCheck2 (strCheck2)
strCheck2 = strCheck2 & "\" & StrName3
FolderCheck2 (strCheck2)
strCheck2 = strCheck2 & "\" & Year(Date)
YearFolderCheck2 (strCheck2)
strCheck2 = strCheck2 & "\" & Format(Date, "mmmm")
YearFolderCheck2 (strCheck2)
strCheck2 = strCheck2 & "\" & StrName4
YearFolderCheck2 (strCheck2)
End With
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.Zoom = False
End With
Sheets("Form").Range("A1:K91").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile2, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
On Error GoTo 0
With OutlApp.CreateItem(0)
.Display
.Subject = ActiveSheet.Range("AA38") & " Completed - " & ActiveSheet.Range("AA33") & " - " & MyDate
.CC = "xxxx#xxx.com"
.HTMLBody = "<pre><BODY style=font-size:11pt;font-family:Calibri>" & Sheets("Form").Range("AA2").Value & "**Click Here to Acknowledge**" & "</body></pre>" & _
.HTMLBody ' Adds default outlook account signature
.Attachments.Add PdfFile
On Error Resume Next
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
' MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
End Sub
Function FolderCheck(strCheck As String)
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
If (fso.FolderExists(strCheck)) Then
Exit Function
Else
fso.createfolder (strCheck)
End If
End Function
Function FolderCheck2(strCheck2 As String)
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
If (fso.FolderExists(strCheck2)) Then
Exit Function
Else
fso.createfolder (strCheck2)
End If
End Function
Function YearFolderCheck(strCheck As String)
Dim fso As Object
Dim strFiller As String
Set fso = CreateObject("scripting.filesystemobject")
If (fso.FolderExists(strCheck)) Then
Exit Function
Else
fso.createfolder (strCheck)
Exit Function
End If
End Function
Function YearFolderCheck2(strCheck2 As String)
Dim fso As Object
Dim strFiller As String
Set fso = CreateObject("scripting.filesystemobject")
If (fso.FolderExists(strCheck2)) Then
Exit Function
Else
fso.createfolder (strCheck2)
Exit Function
End If
End Function
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to paste the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile2, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Specifically, it gets snagged at the above "PdfFile2" export code, which the only difference is the starting path, everything else is the same. It doesn't matter which path I use, if I swap the two, only the first export works and the second one won't. I'm not sure what to do or if there is a better solution to care for the issue.
UPDATE: I updated the code in my workbook and above to pretty much create two separate instances of exporting the file to include dedicated Strings, and it seems to make it through but now triggers Run-time error '76', Path not found, which then highlights the fso.createfolder line
fso.createfolder (strCheck2)
Thank you all in advance!

VBA Macro Vlookup and Index Match function for dynamic number of sheet

I use a macro to run index match and vlookup functions by recording them manually. The problem is that the sheet target is not always available, sometimes only 3 or 5 sheets only so its totally random
here's the code that I use
Sub Function()
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'COA
Sheets(2).Range("A6").FormulaR1C1 = _
"=IFERROR(INDEX('ACF'!R6C:R2000C,MATCH(RC3,'ACF'!R6C3:R2000C3,0)),IFERROR(INDEX('ACF'!R6C:R2000C,MATCH(RC3,'ACF'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('BIGBIKE'!R6C:R2000C,MATCH(RC3,'BIGBIKE'!R6C3:R2000C3,0)),IFERROR(INDEX('BIGBIKE'!R6C:R2000C,MATCH(RC3,'BIGBIKE'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('BOD'!R6C:R2000C,MATCH(RC3,'BOD'!R6C3:R2000C3,0)),IFERROR(INDEX('BOD'!R6C:R2000C,MATCH(RC3,'BOD'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('CORPSEC'!R6C:R2000C,MATCH(RC3,'CORPSEC'!R6C3:R2000C3,0)),IFERROR(INDEX('CORPSEC'!R6C:R2000C,MATCH(RC3,'CORPSEC'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('DIGITAL'!R6C:R2000C,MATCH(RC3,'DIGITAL'!R6C3:R2000C3,0)),IFERROR(INDEX('DIGITAL'!R6C:R2000C,MATCH(RC3,'DIGITAL'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('GDG'!R6C:R2000C,MATCH(RC3,'GDG'!R6C3:R2000C3,0)),IFERROR(INDEX('GDG'!R6C:R2000C,MATCH(RC3,'GDG'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('HC3'!R6C:R2000C,MATCH(RC3,'HC3'!R6C3:R2000C3,0)),IFERROR(INDEX('HC3'!R6C:R2000C,MATCH(RC3,'HC3'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('HRGA'!R6C:R2000C,MATCH(RC3,'HRGA'!R6C3:R2000C3,0)),IFERROR(INDEX('HRGA'!R6C:R2000C,MATCH(RC3,'HRGA'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('IT'!R6C:R2000C,MATCH(RC3,'IT'!R6C3:R2000C3,0)),IFERROR(INDEX('IT'!R6C:R2000C,MATCH(RC3,'IT'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('LDD'!R6C:R2000C,MATCH(RC3,'LDD'!R6C3:R2000C3,0)),IFERROR(INDEX('LDD'!R6C:R2000C,MATCH(RC3,'LDD'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('MCD'!R6C:R2000C,MATCH(RC3,'MCD'!R6C3:R2000C3,0)),IFERROR(INDEX('MCD'!R6C:R2000C,MATCH(RC3,'MCD'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('MSD'!R6C:R2000C,MATCH(RC3,'MSD'!R6C3:R2000C3,0)),IFERROR(INDEX('MSD'!R6C:R2000C,MATCH(RC3,'MSD'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('NPD'!R6C:R2000C,MATCH(RC3,'NPD'!R6C3:R2000C3,0)),IFERROR(INDEX('NPD'!R6C:R2000C,MATCH(RC3,'NPD'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('PARTS'!R6C:R2000C,MATCH(RC3,'PARTS'!R6C3:R2000C3,0)),IFERROR(INDEX('PARTS'!R6C:R2000C,MATCH(RC3,'PARTS'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('PURCHASING'!R6C:R2000C,MATCH(RC3,'PURCHASING'!R6C3:R2000C3,0)),IFERROR(INDEX('PURCHASING'!R6C:R2000C,MATCH(RC3,'PURCHASING'!R6C5:R2000C5,0))" & _
",IFERROR(INDEX('TSD'!R6C:R2000C,MATCH(RC3,'TSD'!R6C3:R2000C3,0)),INDEX('TSD'!R6C:R2000C,MATCH(RC3,'TSD'!R6C5:R2000C5,0))" & _
")))))))))))))))))))))))))))))))"
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
'Status
Sheets(2).Range("D6").FormulaR1C1 = _
"=IFERROR(VLOOKUP(RC3,'ACF'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'ACF'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'BIGBIKE'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'BIGBIKE'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'BOD'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'BOD'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'CORPSEC'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'CORPSEC'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'DIGITAL'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'DIGITAL'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'GDG'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'GDG'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'HC3'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'HC3'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'HRGA'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'HRGA'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'IT'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'IT'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'LDD'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'LDD'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'MCD'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'MCD'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'MSD'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'MSD'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'NPD'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'NPD'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'PARTS'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'PARTS'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'PURCHASING'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'PURCHASING'!R6C5:R2000C12,2,0)" & _
",IFERROR(VLOOKUP(RC3,'TSD'!R6C3:R2000C12,4,0),VLOOKUP(RC3,'TSD'!R6C5:R2000C12,2,0)" & _
")))))))))))))))))))))))))))))))"
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
end sub
is there any way to make the formula run only available sheets on the workbook? because if I run it as is, it always asks to update the formula for the sheet that isn't available on the workbook.
You have to iterate over the sheets in your workbook.
Sub insertCOAandStatusFormulas()
'Pattern of each formula part - $1 as placeholder for sheetname
Dim strPartCOA As String, strPartStatus As String
strPartCOA = "IFERROR(INDEX('$1'!R6C:R2000C,MATCH(RC3,'$1'!R6C3:R2000C3,0)),IFERROR(INDEX('$1'!R6C:R2000C,MATCH(RC3,'$1'!R6C5:R2000C5,0)), "
strPartStatus = "IFERROR(VLOOKUP(RC3,'$1'!R6C3:R2000C12,4,0),IFERROR(VLOOKUP(RC3,'$1'!R6C5:R2000C12,2,0), "
Dim wsTarget As Worksheet
Set wsTarget = ThisWorkbook.Worksheets("Tabelle1") '--> adjust this to your needs
'build sheet-specific part per formula
Dim strFormulaCOA As String, strFormulaStatus As String
Dim cntSheets As Long, i As Long
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> wsTarget.Name Then
strFormulaCOA = strFormulaCOA & Replace(strPartCOA, "$1", ws.Name) & vbCrLf
strFormulaStatus = strFormulaStatus & Replace(strPartStatus, "$1", ws.Name) & vbCrLf
cntSheets = cntSheets + 1
End If
Next
'add equal-sign, remove last comma and add closing brackets
If LenB(strFormulaCOA) > 0 Then
'XXXX this part is not working XXXX - you would have to find out, how many brackets you have to add and at which position they have to go
strFormulaCOA = "=" & Left(strFormulaCOA, Len(strFormulaCOA) - 4) & ", ""no value found""" & String((cntSheets * 2), ")")
strFormulaStatus = "=" & Left(strFormulaStatus, Len(strFormulaStatus) - 4) & ", ""no value found""" & String((cntSheets + 2) + 1, ")")
With wsTarget
.Range("A6").FormulaR1C1 = strFormulaCOA
.Range("D6").FormulaR1C1 = strFormulaStatus
End With
End If
End Sub
You have to make adjustments regarding the brackets - see comment in code

Activating a Worksheet from a Close Window functions as expected but not from an Exit option in an Add-In menubar

I have a Code Workbook and several Data workbooks with multiple worksheets. I need to be able to Activate a particular worksheet when closing a Data workbook. If I use the 'X' in the upper right corner of the Data workbook, the worksheet changes. If I use the Exit option in an Add-In Menu bar, even though the program runs through the same BeforeClose code, it will not Activate the correct worksheet.
The following code is in a code module in the CodeBook.xlsm file:
Option Explicit
Sub Auto_Open()
'Establish a special menu
MenuBars(xlWorksheet).Menus.Add Caption:="O&ptions"
'Create Menu Items
MenuBars(xlWorksheet).Menus("Options").MenuItems.Add Caption:="Open CodeBook1.xlsm", OnAction:="Open_File"
MenuBars(xlWorksheet).Menus("Options").MenuItems.Add Caption:="Exit", OnAction:="AutoClose"
End Sub
Sub Open_File()
Dim sPath As String
sPath = ThisWorkbook.Path
Workbooks.Open sPath & "\DataBook1.xlsm"
End Sub
Public Sub AutoClose()
'See if an Event workbook or the Main workbood called the subroutine
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
ActiveWorkbook.Save
MsgBox "Before ActiveWorkbook.Close"
ActiveWorkbook.Close
MsgBox "Back from ActiveWorkbook.Close"
Exit Sub
End If
End Sub
The following code is in ThisWorkbook in the DataBook1.xlsm which has a Sheet1 and Sheet2:
Public Sub Workbook_BeforeClose(Cancel As Boolean)
Dim sBk As String
Dim cApp As Object
Set cApp = Application
sBk = ThisWorkbook.Name
ThisWorkbook.Save
Worksheets("Sheet2").Activate
MsgBox "Codebook Workbook Before Close After Activate Sheet2" & vbNewLine & _
"ActiveWindow " & ActiveWindow.Caption & vbNewLine & _
"ThisWorkbook " & ThisWorkbook.Name & vbNewLine & _
"ActiveWorkbook " & ActiveWorkbook.Name & vbNewLine & _
"ActiveSheet " & ActiveSheet.Name & vbNewLine & _
"Display Alerts " & Application.DisplayAlerts & vbNewLine & _
"Events Enabled " & Application.EnableEvents & vbNewLine & _
"Screen Updating " & Application.ScreenUpdating
Worksheets("Sheet1").Activate
MsgBox "Codebook Workbook Before Close After Activate Sheet1" & vbNewLine & _
"ActiveWindow " & ActiveWindow.Caption & vbNewLine & _
"ThisWorkbook " & ThisWorkbook.Name & vbNewLine & _
"ActiveWorkbook " & ActiveWorkbook.Name & vbNewLine & _
"ActiveSheet " & ActiveSheet.Name & vbNewLine & _
"Display Alerts " & Application.DisplayAlerts & vbNewLine & _
"Events Enabled " & Application.EnableEvents & vbNewLine & _
"Screen Updating " & Application.ScreenUpdating
' Cancel = True
End Sub
Private Sub Workbook_Open()
Worksheets("Sheet1").Activate
End Sub
To make it easier to test, uncomment the Cancel = True in the DataBook ThisWorkbook code.
My testing would suggest that worksheets can't be "activated" from within ThisWorkbook, that is Workbook_BeforeClose etc. The code runs, but nothing happens.
You might be able to overcome this by executing the activate(s) in a normal code module (which sits in the data worksheet) first.
For example, in a (normal) code module in DataBook1.xlsm add:
Option Explicit
Public Sub SwapSheets()
Worksheets("Sheet2").Activate
MsgBox "Codebook Workbook Before Close After Activate Sheet2" & vbNewLine & _
"ActiveWindow " & ActiveWindow.Caption & vbNewLine & _
"ThisWorkbook " & ThisWorkbook.Name & vbNewLine & _
"ActiveWorkbook " & ActiveWorkbook.Name & vbNewLine & _
"ActiveSheet " & ActiveSheet.Name & vbNewLine & _
"Display Alerts " & Application.DisplayAlerts & vbNewLine & _
"Events Enabled " & Application.EnableEvents & vbNewLine & _
"Screen Updating " & Application.ScreenUpdating
Worksheets("Sheet1").Activate
MsgBox "Codebook Workbook Before Close After Activate Sheet1" & vbNewLine & _
"ActiveWindow " & ActiveWindow.Caption & vbNewLine & _
"ThisWorkbook " & ThisWorkbook.Name & vbNewLine & _
"ActiveWorkbook " & ActiveWorkbook.Name & vbNewLine & _
"ActiveSheet " & ActiveSheet.Name & vbNewLine & _
"Display Alerts " & Application.DisplayAlerts & vbNewLine & _
"Events Enabled " & Application.EnableEvents & vbNewLine & _
"Screen Updating " & Application.ScreenUpdating
End Sub
Then modify your AutoClose in CodeBook.xlsm to call the above first ... before executing the other code.
Public Sub AutoClose()
'See if an Event workbook or the Main workbood called the subroutine
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
' do the activates here first
ActiveWorkbook.Application.Run ("'" & ActiveWorkbook.Name & "'!SwapSheets")
ActiveWorkbook.Save
ActiveWorkbook.Close
Exit Sub
End If
End Sub

Code works when I run it manually, but not when the Workbook_Open event runs

I have a file which when it opens the Workbook_Open event runs the code below. Everything seems to be working correctly, except for a single line of code. The lines of code which state wb.Close savechanges:=False are not executing what is required.
If I immediately trigger this event myself from the Visual Basic editor it runs and then this line of code works.
This does not seem to be an issue if I have the file saved on my hard drive. It only does this when I have the file saved on OneDrive. I am not running this from Excel online. I am running it within the Excel application and opening the file from OneDrive.
Private Sub Workbook_Open()
Dim wb As Workbook: Set wb = ThisWorkbook
Application.ScreenUpdating = False
'Pull User_Name
Range("U_Nm").Value = Application.UserName
'Pull Serial Number from Computer
Dim fsObj As Object
Dim drv As Object
Set fsObj = CreateObject("Scripting.FileSystemObject")
Set drv = fsObj.Drives("C")
Range("SN").Value = Left(Hex(drv.SerialNumber), 4) _
& "-" & Right(Hex(drv.SerialNumber), 4)
Range("Current_Date").Value = Date
'Sheets("Security").Visible = xlSheetVeryHidden
Sheets("Security").Visible = True
'**********CHECK CURRENT VALUES FIRST...IF PASSES THEN PASS...IF IT DOESN'T PASS THEN UPDATE...IF NO INTERNET CONNECTION REQUEST THEY CONNECT TO INTERNET TO CONNECT**********
If Range("Full_Validation").Value <> "Valid" Then
'you must be connected to the internet to proceed
Sheets("Security").Range("Licensing").ListObject.QueryTable.Refresh BackgroundQuery:=False
ActiveSheet.Calculate
If Range("User_Validation").Value <> "Valid" Then
Set objShell = CreateObject("Wscript.Shell")
intMessage = MsgBox("You need to register with Doug & Mark!" & vbCr _
& vbCr _
& "Click 'Yes' below to submit your registration information. You will be notified when your registration is complete." & vbCr _
& vbCr _
& "The information below will be required to complete the registration form." & vbCr _
& vbCr _
& "User Name: " & Application.UserName & vbCr _
& "Computer: " & Range("SN").Value & vbCr _
& "Excel Version: " & Application.Version & " running on " & Application.OperatingSystem, vbYesNo, "Invalid User!")
If intMessage = vbYes Then
objShell.Run ("https://forms.gle/xjB7yA2ehHfU6xoV6")
Else
'Wscript.Quit
End If
MsgBox "The information below is required to complete the registration form." & vbCr _
& vbCr _
& "User Name: " & Application.UserName & vbCr _
& "Computer: " & Range("SN").Value & vbCr _
& "Excel Version: " & Application.Version & " running on " & Application.OperatingSystem, vbInformation, "Invalid User!"
wb.Close savechanges:=False
ElseIf Range("SN_Validation").Value <> "Valid" Then
Set objShell = CreateObject("Wscript.Shell")
intMessage = MsgBox("You need to register with Doug & Mark!" & vbCr _
& vbCr _
& "Click 'Yes' below to submit your registration information. You will be notified when your registration is complete." & vbCr _
& vbCr _
& "The information below will be required to complete the registration form." & vbCr _
& vbCr _
& "User Name: " & Application.UserName & vbCr _
& "Computer: " & Range("SN").Value & vbCr _
& "Excel Version: " & Application.Version & " running on " & Application.OperatingSystem & "!", vbYesNo, "Invalid License!")
If intMessage = vbYes Then
objShell.Run ("https://forms.gle/xjB7yA2ehHfU6xoV6")
Else
'Wscript.Quit
End If
MsgBox "The information below is required to complete the registration form." & vbCr _
& vbCr _
& "User Name: " & Application.UserName & vbCr _
& "Computer: " & Range("SN").Value & vbCr _
& "Excel Version: " & Application.Version & " running on " & Application.OperatingSystem & "!", vbInformation, "Invalid User!"
wb.Close savechanges:=False
ElseIf Range("Expiry_Validation").Value <> "Valid" Then
Set objShell = CreateObject("Wscript.Shell")
intMessage = MsgBox("Your Investment Calculator subscription has Expired!" & vbCr _
& vbCr _
& "You will need to renew your subscription to the Investment Calculator." & vbCr _
& vbCr _
& "Click 'Yes' to renew your subscription now.", _
vbYesNo, "Subscription Renewal")
If intMessage = vbYes Then
objShell.Run ("https://www.sltrib.com/sports/byu-cougars/")
Else
'Wscript.Quit
End If
wb.Close savechanges:=False
End If
'Sheets("Security").VeryHidden = True
Application.ScreenUpdating = True
End If
If Range("Expiry_Date").Value - 5 <= Date Then
Set objShell = CreateObject("Wscript.Shell")
If Range("Expiry_Date").Value - Date = 0 Then
intMessage = MsgBox("Your Investment Calculator subscription will expire Today!" & vbCr _
& vbCr _
& "You will need to renew your subscription to the Investment Calculator." & vbCr _
& vbCr _
& "Click 'Yes' to renew your subscription now.", _
vbYesNo, "Subscription Renewal")
ElseIf Range("Expiry_Date").Value - Date = 1 Then
intMessage = MsgBox("Your Investment Calculator subscription will expire in " & Range("Expiry_Date").Value - Date & " day!" & vbCr _
& vbCr _
& "You will need to renew your subscription to the Investment Calculator." & vbCr _
& vbCr _
& "Click 'Yes' to renew your subscription now.", _
vbYesNo, "Subscription Renewal")
ElseIf Range("Expiry_Date").Value - Date > 0 Then
intMessage = MsgBox("Your Investment Calculator subscription will expire in " & Range("Expiry_Date").Value - Date & " days!" & vbCr _
& vbCr _
& "You will need to renew your subscription to the Investment Calculator." & vbCr _
& vbCr _
& "Click 'Yes' to renew your subscription now.", _
vbYesNo, "Subscription Renewal")
End If
If intMessage = vbYes Then
objShell.Run ("https://www.sltrib.com/sports/byu-cougars/")
End If
End If
If Range("Full_Validation").Value = "Invalid" Then
ThisWorkbook.Close savechanges:=False
End If
Application.ScreenUpdating = True
'Range("U_Nm").ClearContents
'Range("SN").ClearContents
End Sub
I would expect the same behavior that the file would close when this line of code runs. It does work when I have it on my hard drive or it does run if I manually trigger the event. It doesn't work though if it is on OneDrive and is run automatically with the Workbook_Open event.

Excel macro mailmerge - export to pdf

I'm working vba macro which works perfectly but I need save the documents as .pdf.
I´m searching for tips, but I don´t know how to find them. Last time I found this solution : vba mail merge save as pdf
but I don´t know apply it to my macro.
Here is my code:
Sub RunMerge()
Dim wd As Object
Dim wdocSource As Object
Dim strWorkbookName As String
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdocSource = wd.Documents.Open(ThisWorkbook.Path & "\" & "ArtSpecDatabase.docx")
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
wdocSource.MailMerge.MainDocumentType = wdFormLetters
wdocSource.MailMerge.OpenDataSource _
Name:=strWorkbookName, _
AddToRecentFiles:=False, _
Revert:=False, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `Sheet2$`"
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = 1
.LastRecord = 1
End With
.Execute Pause:=False
End With
Dim PathToSave As String
PathToSave = ThisWorkbook.Path & "\" & "pdf" & "\" & Sheets("Sheet2").Range("B2").Value2 & ".docx"
If Dir(PathToSave, 0) <> vbNullString Then
wd.FileDialog(FileDialogType:=msoFileDialogSaveAs).Show
Else
wd.activedocument.SaveAs2 PathToSave, wdFormatDocumentDefault
End If
wd.Visible = True
wdocSource.Close savechanges:=False
wd.activedocument.Close savechanges:=False
Set wdocSource = Nothing
Set wd = Nothing
End Sub
To export a Word document as PDF, you need to use the ExportAsFixedFormat method. For example, you can replace your SaveAs2 call with this:
wd.ActiveDocument.ExportAsFixedFormat PathToSave, 17 'The constant for wdExportFormatPDF
Now, your call to FileDialog makes no sense, so I propose changing the entire Dir(...) If-sentence to this:
Dim PathToSave As String
PathToSave = ThisWorkbook.Path & "\" & "pdf" & "\" & Sheets("Sheet2").Range("B2").Value2 & ".pdf"
If Dir(PathToSave, 0) <> vbNullString Then
With wd.FileDialog(FileDialogType:=msoFileDialogSaveAs)
If .Show = True Then
PathToSave = .SelectedItems(1)
End If
End With
End If
wd.ActiveDocument.ExportAsFixedFormat PathToSave, 17 'The constant for wdExportFormatPDF
EDIT: Forgot to include ".pdf" extension.
Use the below code to export excel to pdf
Sub tst1()
Dim fFilename As String
fFilename = "C:\Documents and Settings\test.xlsx"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
fFilename & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End Sub

Resources