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