Excel MailMerge Export to PDF - excel

Im trying to generate offer letters based on details provide and mail merge it. But i want my output in PDF Format instead of word.
Since it exports the file in word, i want that the final output that is generated is a PDF. But whenever i am trying i am facing with the same error.
Im getting System Error &H80004005 Unspecified Error.
Sub cmdAgree_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.ReferenceStyle = xlA1
' Sheets("DATA").Select
' ActiveSheet.Range("A1").Select
' Selection.End(xlDown).Select
' row_ref = Selection.Row
'
' Sheets("Mail Merge").Range("D4").Value = row_ref
Sheets("Mail Merge").Select
frst_rw = Sheets("Mail Merge").Range("D6").Value
lst_rw = Sheets("Mail Merge").Range("D7").Value
' ActiveWorkbook.Save
'Loop to check if the start row is greater than the last actioned row
If frst_rw = 1 Then
MsgBox "Start row can't be 1. Please check and update to proceed!", vbCritical
Exit Sub
End If
If Sheets("Data").Range("A" & frst_rw).Value = "" Then
MsgBox "No Data to work upon. Please check the reference row used!!!"
Exit Sub
End If
' If frst_rw <= Sheets("Mail Merge").Range("D5").Value And Sheets("Mail Merge").Range("D5").Value <> "" Then
' MsgBox "Start from Row: Cant be less than last actioned row of data in the DATA tab." & vbNewLine _
' & "Please check and update to proceed!", vbCritical
' Exit Sub
' End If
'Loop to check if the last row to generate is greater than the total rows of data
' If lst_rw > Sheets("Mail Merge").Range("D4").Value Then
' MsgBox "End at Row: Cant be greater than total data rows in the DATA tab." & vbNewLine _
' & "Please check and update to proceed!", vbCritical
' Exit Sub
' Else
'Update the last actioned row for future reference
Sheets("Mail Merge").Range("D5").Value = Sheets("Mail Merge").Range("D7").Value
' End If
'Loop though the start row and end row to generate the word documents for different candidates
Dim wd As Object
Dim wdocSource As Object
Dim strWorkbookName As String
On Error Resume Next
'agreement_folder = ThisWorkbook.Path & "\Agreement Template\"
For x = frst_rw - 1 To lst_rw - 1
' For x = frst_rw To lst_rw
'This if condition tackles the choice of group company basis which the template gets selected
If Sheets("DATA").Range("AS" & x + 1).Value = "APPLE" Then
agreement_folder = ThisWorkbook.Path & "\Agreement Template - APPLE\"
ElseIf Sheets("DATA").Range("AS" & x + 1).Value = "BANANA" Then
agreement_folder = ThisWorkbook.Path & "\Agreement Template - BANANA\"
ElseIf Sheets("DATA").Range("AS" & x + 1).Value = "CHERRY" Then
agreement_folder = ThisWorkbook.Path & "\Agreement Template - CHERRY\"
End If
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(agreement_folder & Sheets("DATA").Range("AL" & x + 1).Value)
'Set wdocSource = wd.Documents.Open(agreement_folder & Sheets("DATA").Range("AL" & x).Value)
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
wdocSource.MailMerge.MainDocumentType = wdFormLetters
wdocSource.MailMerge.OpenDataSource _
Name:=strWorkbookName, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `DATA$`"
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = x
.LastRecord = x
End With
.Execute Pause:=False
End With
Dim PathToSave As String
PathToSave = ThisWorkbook.Path & "\" & "pdf" & "\" & Sheets("DATA").Range("B2").Value & ".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
'Sheets("Mail Merge").Select
wd.Visible = True
wdocSource.Close savechanges:=False
wd.ActiveDocument.Close savechanges:=False
Set wdocSource = Nothing
Set wd = Nothing
Next x
Sheets("Mail Merge").Range("D6").ClearContents
Sheets("Mail Merge").Range("D7").ClearContents
MsgBox "All necessary Documents created and are open for your review. Please save and send!", vbCritical
End Sub

Your code is non-trivial, so I'm not going to try to get it setup and working on my side. Instead, I'd suggest adding a Watch Window, and check the results. That should help you isolate the issue and quickly resolve it.
https://www.techonthenet.com/excel/macros/add_watch2016.php
Although error messages are sometimes misleading, it really should help you figure it out, or get close enough to post back with very specific information about what's going on there.

Related

VBA Excel - Open two word documents and add all the info from one to the end of the other

I have a spreadsheet that I want to open two Word documents, do a bunch of stuff and then add all the contents of one to the end of the other. I've managed to figure out how to do the bunch of stuff, but for the life of me I can't seem to copy the contents of one to end of the other (which I thought would be the easiest part).
My code:
Sub Redate_OUT()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayStatusBar = True
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Settings")
Dim pdf_path As String
Dim word_path As String
Dim Updated_path As String
pdf_path = sh.Range("E4").Value
Updated_path = sh.Range("E5").Value
word_path = "\\filestorage\cie\Operations\Results Team\Enquiries About Results\1.Series Folders\June 2022\4. Letters\OUT\Redater\Temporary Folder (Word)"
Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File
Dim MonthNo As Long
Dim MonthType As String
Dim Check As Boolean
Set fo = fso.GetFolder(pdf_path)
Dim wa As Object
Dim doc As Object
Dim FinalWording As Object
Set wa = CreateObject("word.application")
wa.Visible = True
Dim file_Count As Integer
Set FinalWording = wa.Documents.Open("\\filestorage\cie\Operations\Results Team\Enquiries About Results\1.Series Folders\June 2022\4. Letters\OUT\Redater\Final Wording.docx")
For Each f In fo.Files
Application.StatusBar = "Converting - " & file_Count + 1 & "/" & fo.Files.Count
Set doc = wa.Documents.Open(f.Path)
doc.SaveAs2 (word_path & "\" & Replace(f.Name, ".pdf", ".docx"))
doc.Close False
Set doc = wa.Documents.Open(word_path & "\" & Replace(f.Name, ".pdf", ".docx"))
For MonthNo = 12 To 1 Step -1
MonthType = MonthName(MonthNo)
With doc.Content.Find
.Text = "?? " & MonthType & " 2022"
.Replacement.Text = Format(Date, "dd") & " " & MonthName(Format(Date, "mm")) & " " & Format(Date, "yyyy")
.MatchWildcards = True
.MatchWholeWord = True
.Execute Replace:=wdReplaceAll
If .Found = True Then
Check = True
GoTo Done
End If
End With
Next
Done:
If Check = True Then
With doc.Content.Find
.Text = "If you believe we have not arrived at this outcome properly, * Enquiry About Results Team"
.Replacement.Text = ""
.MatchWildcards = True
.MatchWholeWord = True
.Execute Replace:=wdReplaceAll
End With
FinalWording.Content.WholeStory 'Select whole document
Selection.Copy 'Copy your selection
Documents(doc.Name).Activate 'Activate the other document
Selection.EndKey wdStory 'Move to end of document
Selection.PasteAndFormat wdPasteDefault 'Pastes in the content
doc.ExportAsFixedFormat OutputFileName:=Updated_path & "/" & f.Name, ExportFormat:=wdExportFormatPDF, Range:=2
doc.Close
End If
file_Count = file_Count + 1
Next
FinalWording.Close False
wa.Quit
Kill word_path & "\" & "*.docx"
MsgBox "All OUT Letters have been updated", vbInformation
Application.StatusBar = ""
End Sub
My main difficulty is with:
FinalWording.Content.WholeStory 'Select whole document
Selection.Copy 'Copy your selection
Documents(doc.Name).Activate 'Activate the other document
Selection.EndKey wdStory 'Move to end of document
Selection.PasteAndFormat wdPasteDefault 'Pastes in the content
I get an error (Object does not support this property or method) with:
Selection.EndKey wdStory 'Move to end of document
I'm also not convinced that the contents of the FinalWording document is actually being copied, as when I try to paste this manually after that line of code has run, nothing happens.
On a side note, after the PDF is saved as a word document, I've been closing this and opening again to have a variable to use (doc). As I don't need to save the word document, if there's an easier way of doing this without having to close and open it, I would greatly appreciate that.
Many thanks.
You can replace this entire block:
FinalWording.Content.WholeStory 'Select whole document
Selection.Copy 'Copy your selection
Documents(doc.Name).Activate 'Activate the other document
Selection.EndKey wdStory 'Move to end of document
Selection.PasteAndFormat wdPasteDefault 'Pastes in the content
With:
doc.Characters.Last.FormattedText = FinalWording.Content.FormattedText

MailMerge: From Excel to Word Saving Individual Documents for Each Record While Maintaining Link to Source

First I want to say I am extremely new to utilizing VBA to make my excel sheets more efficient.
I started a few months back and mainly generate code by piecing together what I find online then edit to meet my specific needs.
What Current Code Does:
What I have created allows me to perform a multiple document mailmerge from excel to merge records from my datasoure (Project Information) with the click of a button. Before performing the merge, the user identifies 5 conditions;
Zoning (ex. R20; located in cell C8)
Easement Type (ex. TE; located in cell F8)
The Template to use from the previously uploaded template list (located in cell J8)
The Area of the Lot (located in cell P8)
If it is a just compensation Report ("yes" or "no" located in cell C11)
The criteria above identifies the record numbers that match the specified criteria to create individual mailmerge documents for each record and saves in the corresponding property file which is associated with the record number. The sheet that is generating mailmerge ("report Creation") is different from the datasource and maintains records of when the mailmerge was performed and what template was used. This sheet also contains the list of records and is the search range for the criteria (record start on line 39 so +37 is used to match "Report Creation" row).The code also contains a loading bar that appears when the merging is being performed and shows percentage complete (percentage is not correct but used more to show user merge is in progress).
My Question:
What I am now trying to adjust is when the mailmerge is performed I still want the individual documents but I want to maintain the link between the new document and the datasource. That way I can always update the word document if any changes occur. It currently merges to a word document that no longer contains any mailmerge field and is as if I finalized a merge.
I am assuming this is a minor change after the .opendatasource but cant pinpoint what to change.
My Code may be a bit messy and could definitely use some cleanup but it gets the job done. See below.
Current Code:
Sub RunMerge()
Dim StrMMSrc As String, StrMMDoc As String, StrMMDocName As String, StrName As String, dataname As String
Dim i As Long
Dim Load As Integer
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim ReportNum, AddressName, SaveLoc, NewFile, fpath, subfldr, DateCr As String
Dim ExpTemp, ExTempDate, ExpReview, ExpRevDate As Range
Dim ExpRow, CustCol, lastRow, StrMMDocRow, ExportedDoc, LotSizeSM, LotSizeLG, ActualLS, symbpos As Long
Dim FileName, Zoning, Ease, LotSizeRNG, Ztype, Etype As String
On Error GoTo errhandler
'Turn off at the start
TurnOffFunctionality
wdApp.DisplayAlerts = wdAlertsNone
Set wsreports = ThisWorkbook.Worksheets("Report Creation")
Set wsinfo = ThisWorkbook.Worksheets("Project Information")
Set wsdetails = ThisWorkbook.Worksheets("Project Details")
StrMMSrc = ThisWorkbook.fullname
lastRow = wsinfo.Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).row
dataname = wsinfo.Name
'set folder path for saving documents
fpath = ThisWorkbook.Sheets("Project Details").Range("E30").Value
subfldr = wsdetails.Range("F34").Value
'date exported
DateCr = Format(Date, "mm-dd-yyyy")
ExportedDoc = 0
With wsreports
' set range criteria
LotSizeRNG = .Range("P8").Value
symbpos = InStr(1, LotSizeRNG, "<>")
LotSizeSM = CInt(Left(LotSizeRNG, symbpos - 1))
LotSizeLG = CInt(Mid(LotSizeRNG, symbpos + 2))
If LotSizeLG = "" Then LotSizeLG = 100000000
If wsreports.Range("J8").Value = Empty Then
MsgBox "Please Select A Template From The Dropdown List to Export"
wsreports.Range("J8").Select
GoTo errhandler
End If
StrMMDocRow = .Application.Match(Range("J8").Value, .Range("C1:C34"), 0) 'Set Template Row
StrMMDocName = .Range("J8").Value 'set template name
Zoning = .Range("C8").Value 'set Zoning Criteria
Ease = .Range("F8").Value 'Set Easement Criteria
StrMMDoc = .Range("AB" & StrMMDocRow).Value 'Word Document Filename
End With
wdApp.Visible = False
Set wdDoc = wdApp.Documents.Open(FileName:=StrMMDoc, AddToRecentFiles:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=StrMMSrc, AddToRecentFiles:=False, LinkToSource:=False,
ConfirmConversions:=False, _
ReadOnly:=True, Format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"User ID=Admin;Data Source=" & StrMMSrc & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";", _
SQLStatement:="SELECT * FROM `Project Information$`", SQLStatement1:="", SubType:=wdMergeSubTypeAccess
UserFormLoad.Show
For i = 2 To lastRow
Ztype = wsreports.Range("D" & i + 37).Value
Etype = wsreports.Range("F" & i + 37).Value
ActualLS = wsreports.Range("E" & i + 37).Value
'Check the row for matching zone and easement cristeria
If wsreports.Range("C11").Value = "No" And StrMMDocName <> wsreports.Range("H" & i + 37).Value _
And Ztype = Zoning And ActualLS >= LotSizeSM And ActualLS <= LotSizeLG And Etype = Ease Then
ExportedDoc = ExportedDoc + 1
'set newfile location
ReportNum = wsreports.Range("B" & i + 37).Value
AddressName = wsreports.Range("C" & i + 37).Value
SaveLoc = fpath & "\#" & ReportNum & "_" & AddressName & "\" & subfldr
'generate new file name with date
NewFile = SaveLoc & "\" & AddressName & "_Draft Report_" & DateCr & ".docx"
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i - 1
.LastRecord = i - 1
.ActiveRecord = i - 1
StrName = NewFile
End With
.Execute Pause:=False
wsreports.Range("I" & i + 37).Value = StrMMDocName
wsreports.Range("L" & i + 37).Value = DateCr
With wdApp.ActiveDocument
.SaveAs FileName:=StrName, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close savechanges:=False
End With
Dim r As Integer
r = i
Load = Application.WorksheetFunction.RoundDown((r + 1) / (lastRow) * 100, 0)
DoEvents
UserFormLoad.LoadBar.Width = Load / 100 * 222
UserFormLoad.LabelProg.Caption = Load & "%"
End If
Next i
Unload UserFormLoad
.MainDocumentType = wdNotAMergeDocument
End With
.Close savechanges:=False
End With
If ExportedDoc = 0 Then
MsgBox "No Properties Matched The Criteria Specified. Use The Table To Verify The Easement and Zoning Have Properties Meeting Criteria.", vbOKOnly, "No Matches Found"
Else
MsgBox "The Property Draft Reports Were Exported Successfully. Please Check Project Property" & subfldr & " Folder for Word Document.", vbOKOnly, "Export Successfull"
End If
'cleanup if error
errhandler:
TurnOnFunctionality
wdApp.DisplayAlerts = wdAlertsAll
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
You cannot use mailmerge for what you want to achieve. You would need to use LINK fields instead of MERGEFIELDs and update the LINK field row references for each output document.
An alternative approach would be to re-run the mailmerge for just the record(s) you want to update.

Sending Data from Word Into Excel: Run-time error: '424' Object Required

I am trying to send data to Excel from Word after an email is sent. I have the email and the rest of it working. Now, I am trying to get the part with Excel working.
Private Sub btnGenerateEmail_Click()
'Instatiate Application Objects (using late binding)
Dim App As Object
Dim Msg As Object
Const olMailItem As Long = 0
'Declare Form Variables
Dim EmplName As String: EmplName = Me.frmEmployeeName
Dim IncidentDesc As String: IncidentDesc = Me.frmIncidentDescription
Dim EmplTrain As String: EmplTrain = Me.frmEmployeeTraining
Dim FaceOnRack As String: FaceOnRack = Me.frmFaceOnRack
Dim DrawingProb As String: DrawingProb = Me.frmDrawingProblem
Dim JobNum As String: JobNum = Me.frmJobNumber
Dim DrwNum As String: DrwNum = Me.frmDrawingNumber
Dim FaceDesc As String: FaceDesc = Me.frmFaceDescription
Dim Qty As String: Qty = Me.frmQty
Dim StockOrNon As String: StockOrNon = Me.frmStockOrNon
Dim FaceReplace As String: FaceReplace = Me.frmFaceReplace
'Set Application Objects (using late binding)
Set App = CreateObject("Outlook.Application")
Set Msg = App.CreateItem(olMailItem)
'Data validation
If IsNull(EmplName) Or EmplName = "" Then
MsgBox ("Please enter the employee's name."), vbCritical
Exit Sub
End If
If IsNull(IncidentDesc) Or IncidentDesc = "" Then
MsgBox ("Please describe how the face was broken."), vbCritical
Exit Sub
End If
If IsNull(EmplTrain) Or EmplTrain = "" Then
MsgBox ("Does the employee need more training to avoid these kind of incidents in the future?"), vbCritical
Exit Sub
End If
If IsNull(FaceOnRack) Or FaceOnRack = "" Then
MsgBox ("Was the already broken when on rack?"), vbCritical
Exit Sub
End If
If IsNull(DrawingProb) Or DrawingProb = "" Then
MsgBox ("Was the face scrapped because of an issue with the drawing/art?"), vbCritical
Exit Sub
End If
If IsNull(JobNum) Or JobNum = "" Then
MsgBox ("Please enter the job number or traveler number."), vbCritical
Exit Sub
End If
If IsNull(DrwNum) Or DrwNum = "" Then
MsgBox ("Please enter the drawing number."), vbCritical
Exit Sub
End If
If IsNull(FaceDesc) Or FaceDesc = "" Then
MsgBox ("Please enter a description of the face being scrapped."), vbCritical
Exit Sub
End If
If IsNull(Qty) Or Qty = "" Then
MsgBox ("Please enter the quantity being scrapped."), vbCritical
Exit Sub
End If
If IsNull(StockOrNon) Or StockOrNon = "" Then
MsgBox ("Is the face stock or non-stock?"), vbCritical
Exit Sub
End If
If IsNull(FaceReplace) Or FaceReplace = "" Then
MsgBox ("Does this face need to be replaced?"), vbCritical
Exit Sub
End If
'Compose HTML Message Body
Dim HTMLContent As String
HTMLContent = "<p style='font-family:Calibri; font-size:14px;'>This email is an autogenerated scrap face incident report.</p>" _
& "<table style='font-family:Calibri; font-size:14px;' width='75%' border='1' bordercolor='black' cellpadding='5'>" _
& "<tr><td width='65%'>Employee Name</td><td>" & EmplName & "</td></tr>" _
& "<tr><td>How was the face broken?</td><td>" & IncidentDesc & "</td></tr>" _
& "<tr><td>Does employee in question need more training to prevent future incidents?</td><td>" & EmplTrain & "</td></tr>" _
& "<tr><td>Was the face found on the rack already broken?</td><td>" & FaceOnRack & "</td></tr>" _
& "<tr><td>Was the face scrapped because of an issue with the drawing/art?</td><td>" & DrawingProb & "</td></tr>" _
& "<tr><td>Job/Traveler Number:</td><td>" & JobNum & "</td></tr>" _
& "<tr><td>Drawing Number:</td><td>" & DrwNum & "</td></tr>" _
& "<tr><td>Face Description:</td><td>" & FaceDesc & "</td></tr>" _
& "<tr><td>Quantity</td><td>" & Qty & "</td></tr>" _
& "<tr><td>Stock or Non-Stock</td><td>" & StockOrNon & "</td></tr>" _
& "<tr><td>Does this face need to be replaced?</td><td>" & FaceReplace & "</td></tr>" _
& "</table>"
'Construct the email, pass parameter values, & send the email
With Msg
.To = "test#test.com"
.Subject = "Scrap Face Incident Report"
.HTMLBody = HTMLContent
.Display
'.Send
End With
'MAY NEED WORK
'Make sure the generated email is the active window
App.ActiveWindow.WindowState = olMaximized
'Application.Windows("Scrap Face Incident Report - Message (HTML)").Activate
'Create entry in scrap report
Dim ScrapReportFile As String
ScrapReportFile = "\\jacksonville-dc\common\SOP's for JV\WIP\Jonathan\JG - How to Replace Scrapped Faces\Scrap List (Faces).xlsx"
'File exists
If Dir(ScrapReportFile) <> "" Then
Dim ObjExcel As Object, ObjWb As Object, ObjWorksheet As Object
Set ObjExcel = CreateObject("EXCEL.APPLICATION")
Set ObjWb = ObjExcel.Workbooks.Open(ScrapReportFile)
ObjExcel.Visible = True
With ObjWb.Worksheets(3)
Dim lastrow As Long: lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox (lastrow)
End With
'ObjWb.Worksheets(1).Range("A1") = "SOP Title: " & SOPTitle
'ObjWb.Worksheets(1).Range("F1") = "Date: " & Format(Now, "MM/dd/yyyy")
'ObjWb.Save
'ObjWb.Close
End If
'File does not exist; throw error
End Sub
On this section of code:
With ObjWb.Worksheets(3)
Dim lastrow As Long: lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox (lastrow)
End With
I am trying to send the data gathered from the form and create a new row at the bottom of the sheet and then insert the data into specified columns. When I am doing the .Cells(.Rows.Count...etc I am getting an error.
Run-time error: '424' Object Required
Word doesn't know what xlUp is, because that is from the Excel object model.
Add the following line:
Const xlUp as Long = -4162
as per the documentation of xlUps corresponding value.

Original "start date" of postponed appointment

Hopefully someone could help :)
I use VBA code that runs through Microsoft Outlook Appointments, and for each appointment - prints a few details - to an Excel table.
If I set the start date of an appointment on 01-April-2019, and then postpone that appointment to 12-April-2019, and then postpone that appointment to 15-April-2019 - I have 3 "Appointment Item" objects in my folder.
I would like to print for each appointment in the folder - the "Start Date" that was set originally.
For example: Print for the first appointment - the first original start date (01-April-2019), for the first postponed appointment - the first postponed start date (12-April-2019), and for the second postponed appointment - the second postponed start date (15-April-2019).
However, when I run my code - the last "Start Date" is printed (15-April-2019, 15-April-2019, 15-April-2019), instead of the original (01-April-2019, 12-April-2019, 15-April-2019) .
I read a lot about different types of "date" objects, but couldn't find the correct one.
Could anyone help me?
Thank you very much!
Sub GetFromOutlook()
'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Dim OutlookApp As Outlook.Application
Dim OutlookNS As Namespace
Dim Folder As MAPIFolder
Dim oApp As Outlook.Application
Dim oG As Outlook.Folder 'Method for IMAP, as used by Gmail.
Dim oM As Outlook.MeetingItem
Dim oAA As Outlook.AppointmentItem
Dim oI As Outlook.RecurrencePattern
Dim sMsg$, sAdd$
Dim i As Long
Dim j As Long
Set OutlookApp = New Outlook.Application
Set OutlookNS = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNS.GetDefaultFolder(olFolderInbox).Parent.Folders("CCB Meetings")
Dim icon As String
Set oApp = CreateObject("Outlook.Application")
Set oG = OutlookNS.GetDefaultFolder(olFolderInbox).Parent.Folders("CCB Meetings")
For i = 1 To oG.Items.Count
If TypeName(oG.Items(i)) = "MeetingItem" Then j = j + 1
Next i
If j = 0 Then Exit Sub
' Create titles
Range("A1").Offset(0, 0).Value = "SenderName"
Range("B1").Offset(0, 0).Value = "Subject"
Range("C1").Offset(0, 0).Value = "CreationTime (Scheduled time of the first appointment)"
Range("D1").Offset(0, 0).Value = "ReceivedTime (Scheduled time of the current appointment)"
Range("E1").Offset(0, 0).Value = "Start (start time of the last scheduled appointment)"
Range("F1").Offset(0, 0).Value = "StartTime (doesnt work yet)"
Range("G1").Offset(0, 0).Value = "Location"
Range("H1").Offset(0, 0).Value = "RequiredAttendees"
Range("I1").Offset(0, 0).Value = "OptionalAttendees"
Range("J1").Offset(0, 0).Value = "ResponseStatus"
On Error Resume Next
j = 0
For i = 1 To oG.Items.Count
Set oM = oG.Items(i)
With oG.Items(i).GetAssociatedAppointment(True)
j = j + 1
Range("A1").Offset(j, 0).Value = oM.SenderName
Range("B1").Offset(j, 0).Value = oM.Subject
Range("C1").Offset(j, 0).Value = .CreationTime
Range("D1").Offset(j, 0).Value = oM.ReceivedTime
Range("E1").Offset(j, 0).Value = .Start
Range("F1").Offset(j, 0).Value = oAA.GetRecurrencePattern '??????????????????
Range("G1").Offset(j, 0).Value = .Location
Range("H1").Offset(j, 0).Value = .RequiredAttendees
Range("I1").Offset(j, 0).Value = .OptionalAttendees
Range("J1").Offset(j, 0).Value = .ResponseStatus
End With
Next i
On Error GoTo 0
Set Folder = Nothing
Set OutlookNS = Nothing
Set OutlookApp = Nothing
End Sub
You can create a UserProperties field manually or Add a UserProperties field with VBA code.
UserProperties object
UserProperties.Add method
OlUserPropertyType enumeration
Once you have the field you can enter data manually or with VBA.
With VBA consider ItemAdd. Set custom value when item moved to folder in outlook
I have just noticed Niton's latest comment. I think it is an interesting idea. I suspect you still need my investigative macro and you will still need events to create the custom property so this answer should still be useful.
I would need to invest more time than I have available at the moment to address your requirement. This answer includes what I have to hand in the hope that it will help you.
Your code suggests you do not understand recurring entries, you are not familiar with the different types of calendar items and you have misinterpreted some of the properties. If there is any detailed documentation on calendar items available via the internet, I have failed to find it. There is basic documentation (referenced below): this object has these properties; this property is a long/string/enumeration; one sentence definitions and so on. But none of this basic documentation helped me understand how, for example, exceptions related to master entries.
The code below is an Excel based investigation I conducted some months ago. I have not had the time to move to the next stage but I believe it will give you a start.
Option Explicit
Sub DiagCal()
' Outputs major properties of all calendar items within the default
' calendar for a specified date range. The objective is to better
' understand calendar items and how they link.
' Requires reference to Microsoft Outlook nn.n Library
' where "nn.n" identifies the version of Office you are using.
' 27Dec18 First version coded
' 30Dec18 This version coded
' 18Apr19 Reviewed comments and made some improvements.
' * Together these constants identify the start and length of the report period.
' * The report period starts DateReportStartOffset days before today.
' * DateReportLenType and DateReportLen are used as parameters for function DateAdd
' which is used to calculate the report period end date for the start date. See
' function DateAdd for permitted values for these constants.
' * These constants provided a convenient way of specify the start and end date
' of the report period when this macro was written. Something simpler would
' probably be better now.
Const DateReportLen As Long = 1
Const DateReportLenType As String = "yyyy"
Const DateReportStartOffset As Long = -363
Dim AppointToReport As New Collection
Dim AppOutlook As New Outlook.Application
Dim CalEnt As Object
Dim CalEntClass As Long
Dim DateReportEnd As Date
Dim DateReportStart As Date
Dim FileBody As String
Dim FldrCal As Outlook.Folder
Dim InxAir As Long
Dim InxFC As Long
Dim PathDesktop As String
PathDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
' Identify date range to be reported on
DateReportStart = DateSerial(Year(Now), Month(Now), Day(Now) + DateReportStartOffset)
DateReportEnd = DateAdd(DateReportLenType, DateReportLen, DateReportStart)
' This assumes the calendar of interest is the default calendar.
' Change as necessary
Set FldrCal = AppOutlook.Session.GetDefaultFolder(olFolderCalendar)
' This loop reviews the entire calendar and identifies Calendar Items
' that fall entirely or partially within the report period. All such
' Calendar Items are recorded in collection AppointToReport.
For InxFC = 1 To FldrCal.Items.Count
Set CalEnt = FldrCal.Items(InxFC)
' Occasionally I get syncronisation errors. This code avoids them.
CalEntClass = -1
On Error Resume Next
CalEntClass = CalEnt.Class
On Error GoTo 0
' I have never found anything but appointments in
' Calendar but test just in case
If CalEntClass = olAppointment Then
Call DiagCalRecordEntry(CalEnt, DateReportStart, DateReportEnd, AppointToReport)
End If
Next InxFC
FileBody = "Calendar entries within or partially within " & _
Format(DateReportStart, "d mmm yy") & _
" to " & Format(DateReportEnd, "d mmm yy") & vbLf & _
"Total calendar entries: " & FldrCal.Items.Count & vbLf & _
"Calendar entries within or partially within report period: " & _
AppointToReport.Count
' This loop outputs the major properties of every Calendar Items recorded
' in collection AppointToReport.
For InxAir = 1 To AppointToReport.Count
FileBody = FileBody & vbLf & String(70, "=")
FileBody = FileBody & vbLf & AppointToReport(InxAir)(1)
Next
Call PutTextFileUtf8NoBom(PathDesktop & "\Calendar.txt", FileBody)
End Sub
Sub DiagCalRecordEntry(ByRef CalEnt As Object, _
ByVal DateReportStart As Date, _
ByVal DateReportEnd As Date, _
ByRef AppointToReport As Collection, _
Optional ByVal OriginalDate As Date)
' If calendar entry is within or partially within report range, add
' its details to AppointToReport
Dim AllDayEvent As Boolean
Dim AppointDtls As String
Dim AppointId As String
Dim AppointIdMaster As String
Dim BusyStatus As String
Dim DateRecurrEnd As Date
Dim DateRecurrStart As Date
Dim DateAppointEnd As Date
Dim DateAppointStart As Date
Dim DayOfMonth As Long
Dim DayOfWeekMask As String
Dim DayOfWeekMaskCode As Long
Dim DurationEntry As Long
Dim DurationRecurr As Long
Dim InxE As Long
Dim Instance As Long
Dim Interval As Long
Dim Location As String
Dim MonthOfYear As Long
Dim NoEndDate As Boolean
Dim NumOccurrences As Long
Dim RecurrenceState As String
Dim RecurrenceType As String
Dim RecurrPattern As Outlook.RecurrencePattern
Dim Subject As String
Dim TimeStart As Date
Dim TimeEnd As Date
'Debug.Assert False
' Get values from calendar entry which identify if entry is within
' report range
With CalEnt
DateAppointStart = .Start
DateAppointEnd = .End
Select Case .RecurrenceState
Case olApptNotRecurring
'Debug.Assert False
RecurrenceState = "Non-recurring calendar entry"
Case olApptMaster
'Debug.Assert False
RecurrenceState = "Master calendar entry"
Case olApptException
'Debug.Assert False
RecurrenceState = "Exception to Master calendar entry"
Case olApptOccurrence
Debug.Assert False
' I believe this state can only exist if GetOccurrence() is used
' to get a single occurrence of a Master entery. I do not believe
' it can appear as a calendar entry
RecurrenceState = "Occurrence"
Case Else
Debug.Assert False
RecurrenceState = "Unrecognised (" & .RecurrenceState & ")"
End Select
End With
If RecurrenceState = "Master calendar entry" Then
'Debug.Assert False
Set RecurrPattern = CalEnt.GetRecurrencePattern()
With RecurrPattern
DateRecurrStart = .PatternStartDate
DateRecurrEnd = .PatternEndDate
End With
If DateRecurrStart <= DateReportEnd And _
DateRecurrEnd >= DateReportStart Then
' Some or all occurences of this Master entry are within report range
'Debug.Assert False
Else
' No occurences of this Master entry are within report range
'Debug.Assert False
Exit Sub
End If
Else
' Non recurring or exception appointment
If DateAppointStart <= DateReportEnd And _
DateAppointEnd >= DateReportStart Then
' Entry is within report range
'Debug.Assert False
Else
' Non recurring entry is not within report range
'Debug.Assert False
Exit Sub
End If
End If
' Calendar entry is within or partially within report period
' Get remaining properties from entry
'Debug.Assert False
With CalEnt
AllDayEvent = .AllDayEvent
AppointId = .GlobalAppointmentID
Select Case .BusyStatus
Case olBusy
'Debug.Assert False
BusyStatus = "Busy"
Case olFree
'Debug.Assert False
BusyStatus = "Free"
Case olOutOfOffice
'Debug.Assert False
BusyStatus = "Out of Office"
Case olTentative
Debug.Assert False
BusyStatus = "Tentative appointment"
Case olWorkingElsewhere
'Debug.Assert False
BusyStatus = "Working elsewhere"
Case Else
Debug.Assert False
BusyStatus = "Not recognised (" & .BusyStatus & ")"
End Select
Location = .Location
Subject = .Subject
End With
If RecurrenceState = "Exception to Master calendar entry" Then
RecurrenceState = RecurrenceState & vbLf & _
"Master's Id: " & CalEnt.Parent.GlobalAppointmentID & vbLf & _
"Original Date: " & OriginalDate
End If
AppointDtls = RecurrenceState & vbLf & _
"AllDayEvent: " & AllDayEvent & vbLf & _
"AppointId: " & AppointId & vbLf & _
"BusyStatus: " & BusyStatus & vbLf & _
"DateAppointStart: " & DateAppointStart & vbLf & _
"DateAppointEnd: " & DateAppointEnd & vbLf & _
"DurationEntry: " & DurationEntry & vbLf & _
"Location: " & Location & vbLf & _
"Subject: " & Subject
If RecurrenceState <> "Master calendar entry" Then
' AppointDtls complete for this appointment
Call StoreSingleAppoint(Format(DateAppointStart, "yyyymmddhhmm"), _
AppointDtls, AppointToReport)
Else
'Debug.Assert False
With RecurrPattern
' Not all parameters have a meaningful value for all RecurrenceTypes
' but the value always appears to be of the correct data type.
DateRecurrStart = .PatternStartDate
DateRecurrEnd = .PatternEndDate
DayOfMonth = .DayOfMonth
DayOfWeekMaskCode = .DayOfWeekMask
DayOfWeekMask = ""
If DayOfWeekMaskCode >= olSaturday Then
Debug.Assert False
DayOfWeekMask = "+Saturday"
DayOfWeekMaskCode = DayOfWeekMaskCode - olSaturday
End If
If DayOfWeekMaskCode >= olFriday Then
'Debug.Assert False
DayOfWeekMask = "+Friday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olFriday
End If
If DayOfWeekMaskCode >= olThursday Then
'Debug.Assert False
DayOfWeekMask = "+Thursday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olThursday
End If
If DayOfWeekMaskCode >= olWednesday Then
'Debug.Assert False
DayOfWeekMask = "+Wednesday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olWednesday
End If
If DayOfWeekMaskCode >= olTuesday Then
'Debug.Assert False
DayOfWeekMask = "+Tuesday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olTuesday
End If
If DayOfWeekMaskCode >= olMonday Then
'Debug.Assert False
DayOfWeekMask = "+Monday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olMonday
End If
If DayOfWeekMaskCode >= olSunday Then
'Debug.Assert False
DayOfWeekMask = "+Sunday" & DayOfWeekMask
End If
If DayOfWeekMask = "" Then
'Debug.Assert False
DayOfWeekMask = "None"
Else
'Debug.Assert False
DayOfWeekMask = Mid$(DayOfWeekMask, 2) ' Remove leading +
End If
DurationRecurr = .Duration
Instance = .Instance
Interval = .Interval
MonthOfYear = .MonthOfYear
NoEndDate = .NoEndDate
NumOccurrences = .Occurrences
Select Case .RecurrenceType
Case olRecursDaily
'Debug.Assert False
RecurrenceType = "Daily"
Case olRecursMonthly
Debug.Assert False
RecurrenceType = "Monthly"
Case olRecursMonthNth
Debug.Assert False
RecurrenceType = "MonthNth"
Case olRecursWeekly
'Debug.Assert False
RecurrenceType = "Weekly"
Case olRecursYearly
'Debug.Assert False
RecurrenceType = "Yearly"
Case olRecursYearNth
Debug.Assert False
RecurrenceType = "YearNth"
Case Else
Debug.Assert False
RecurrenceType = "Unrecognised Value (" & RecurrenceType & ")"
End Select
TimeStart = .StartTime
TimeEnd = .EndTime
End With
AppointDtls = AppointDtls & vbLf & "DateRecurrStart: " & DateRecurrStart _
& vbLf & "DateRecurrEnd: " & DateRecurrEnd _
& vbLf & "DayOfMonth: " & DayOfMonth _
& vbLf & "DayOfWeekMask: " & DayOfWeekMask _
& vbLf & "DurationRecurr: " & DurationRecurr _
& vbLf & "Instance: " & Instance _
& vbLf & "Interval: " & Interval _
& vbLf & "MonthOfYear: " & MonthOfYear _
& vbLf & "NoEndDate: " & NoEndDate _
& vbLf & "NumOccurrences: " & NumOccurrences _
& vbLf & "RecurrenceType: " & RecurrenceType _
& vbLf & "TimeStart: " & TimeStart & " (" & CDbl(TimeStart) & ")" _
& vbLf & "TimeEnd: " & TimeEnd & " (" & CDbl(TimeEnd) & ")"
For InxE = 1 To RecurrPattern.Exceptions.Count
AppointDtls = AppointDtls & vbLf & "Exception " & InxE & " for occurrence on " & _
RecurrPattern.Exceptions.Item(InxE).OriginalDate
Next
Call StoreSingleAppoint(Format(DateRecurrStart, "yyyymmddhhmm"), _
AppointDtls, AppointToReport)
For InxE = 1 To RecurrPattern.Exceptions.Count
Call DiagCalRecordEntry(RecurrPattern.Exceptions.Item(InxE).AppointmentItem, _
DateReportStart, DateReportEnd, AppointToReport, _
RecurrPattern.Exceptions.Item(InxE).OriginalDate)
Next
End If ' RecurrenceState <> "Master calendar entry"
End Sub
Public Sub PutTextFileUtf8NoBom(ByVal PathFileName As String, ByVal FileBody As String)
' Outputs FileBody as a text file named PathFileName using
' UTF-8 encoding without leading BOM
' Needs reference to "Microsoft ActiveX Data Objects n.n Library"
' Addition to original code says version 2.5. Tested with version 6.1.
' 1Nov16 Copied from http://stackoverflow.com/a/4461250/973283
' but replaced literals with parameters.
' 15Aug17 Discovered routine was adding an LF to the end of the file.
' Added code to discard that LF.
' 11Oct17 Posted to StackOverflow
' 9Aug18 Comment from rellampec suggested removal of adWriteLine from
' WriteTest statement would avoid adding LF.
' 30Sep18 Amended routine to remove adWriteLine from WriteTest statement
' and code to remove LF from file. Successfully tested new version.
' References: http://stackoverflow.com/a/4461250/973283
' https://www.w3schools.com/asp/ado_ref_stream.asp
Dim BinaryStream As Object
Dim UTFStream As Object
Set UTFStream = CreateObject("adodb.stream")
UTFStream.Type = adTypeText
UTFStream.Mode = adModeReadWrite
UTFStream.Charset = "UTF-8"
UTFStream.Open
UTFStream.WriteText FileBody
UTFStream.Position = 3 'skip BOM
Set BinaryStream = CreateObject("adodb.stream")
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
UTFStream.CopyTo BinaryStream
UTFStream.Flush
UTFStream.Close
Set UTFStream = Nothing
BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
BinaryStream.Flush
BinaryStream.Close
Set BinaryStream = Nothing
End Sub
Sub StoreSingleAppoint(ByVal SeqKey As String, _
ByVal AppointDtls As String, _
ByRef AppointToReport As Collection)
' Entries in AppointToReport are of the form:
' VBA.Array(SeqKey, AppointDtls)
' Add new entry to AppointToReport so entries are in ascending order by SeqKey
Dim InxAtr As Long
If AppointToReport.Count = 0 Then
'Debug.Assert False
' first appointment
AppointToReport.Add VBA.Array(SeqKey, AppointDtls)
Else
For InxAtr = AppointToReport.Count To 1 Step -1
If SeqKey >= AppointToReport(InxAtr)(0) Then
' New appointment belongs after this existing entry
'Debug.Assert False
AppointToReport.Add VBA.Array(SeqKey, AppointDtls), , , InxAtr
Exit Sub
End If
Next
' If get here, new appointment belongs before all existing appointments
'Debug.Assert False
AppointToReport.Add VBA.Array(SeqKey, AppointDtls), , 1
End If
End Sub
Create a macro-enabled workbook and copy the above code to a module.
Near the top of the code you will find:
' Identify date range to be reported on
DateReportStart = DateSerial(Year(Now), Month(Now), Day(Now) + DateReportStartOffset)
DateReportEnd = DateAdd(DateReportLenType, DateReportLen, DateReportStart)
I suggest replacing these statements with something simple like:
DateReportStart = #4/15/2019#
DateReportEnd = #4/18/2019#
Warning: VBA date literals use middle-endian format which confuses everyone except civilian Americans.
Macro DiagCal() creates a desktop file named “Calendar.txt” containing details of every calendar item that is entirely or partially within the report period. When I tested it, I created every sort of calendar entry: single appointments; entries recurring by day, week, month, year; weekly patterns; multi-day, all-day and part-day events; exceptions to instances of recurring entries and so on.
Visit https://learn.microsoft.com/en-us/office/vba/api/Outlook.AppointmentItem
On the left is an index with entries for the events, methods and properties of an appointment item. Expand the properties and methods and look for information that did not interest me but might interest you. Look through my code and workout how to add that information. If you cannot see how to add information, report the information you want in a comment and I will add it for you.
Expand the events and study what is available. I have never used appointment item events. I have found events easy enough to use with mail items so I assume appointment items will be similar. It is not immediate clear to me which would be the best events to use. I think you need to know when a new item is added and when an item is changed. I would try some of these events and write code to output a few properties to the Immediate Windows to better understand when these events are triggered and what data is available.
I believe you will have to initialise your workbook with code something like my macro which extracts the interesting properties of existing appointment items. You then need events to output the interesting properties of new or changed events.
I would not use events to update the workbook. (1) If you update the workbook in real time there will probably be a noticeable delay while the event is processed. (2) The update code is likely to be complex and unlikely to be correct on first attempt. If you update the workbook in real time, you will have to cause the events to be triggered again and again until you get the code right.
I would get each event to output a small text file, containing the interesting properties, to a suitable disc folder. Outputting a text file will be take little time and should not be noticeable to the user. These text files can be used again and again to update the workbook until you get the code right.
I hope the above gives you some ideas.

VBA reference sheetname in excel

We have a excel file with a bunch of sheets. The first sheet is a "Search page" thing... where we want to type the name of the spreadsheet (for example in cell A1) we are looking for and then that would automatically pop up the right spreadsheet (within the same file).
I tried that, it didn't work at all :
Function ActivateWB(wbname As String)
'Open wbname.
Workbooks(wbname).Activate
End Function
Two code sets below
Add a full hyperlinked Table of Contents page
For your specific question re finding a sheet that is referred to by A1 on the first sheet see 'JumpSheet' code (at bottom)
Create TOC
Option Explicit
Sub CreateTOC()
Dim ws As Worksheet
Dim nmToc As Name
Dim rng1 As Range
Dim lngProceed As Boolean
Dim bNonWkSht As Boolean
Dim lngSht As Long
Dim lngShtNum As Long
Dim strWScode As String
Dim vbCodeMod
'Test for an ActiveWorkbook to summarise
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
'Turn off updates, alerts and events
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed
On Error Resume Next
Set nmToc = ActiveWorkbook.Names("TOC_Index")
If Not nmToc Is Nothing Then
lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")
If lngProceed = vbYes Then
Exit Sub
Else
ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete
End If
End If
Set ws = ActiveWorkbook.Sheets.Add
ws.Move before:=Sheets(1)
'Add the marker range name
ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]
ws.Name = "TOC_Index"
On Error GoTo 0
On Error GoTo ErrHandler
For lngSht = 2 To ActiveWorkbook.Sheets.Count
'set to start at A6 of TOC sheet
'Test sheets to determine whether they are normal worksheets
ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))
If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then
'Add hyperlinks to normal worksheets
ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name
Else
'Add name of any non-worksheets
ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name
'Colour these sheets yellow
ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow
ws.Cells(lngSht + 4, 2).Font.Italic = True
bNonWkSht = True
End If
Next lngSht
'Add headers and formatting
With ws
With .[a1:a4]
.Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))
.Font.Size = 14
.Cells(1).Font.Bold = True
End With
With .[a6].Resize(lngSht - 1, 1)
.Font.Bold = True
.Font.ColorIndex = 41
.Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft
.Columns("A:B").EntireColumn.AutoFit
End With
End With
'Add warnings and macro code if there are non WorkSheet types present
If bNonWkSht Then
With ws.[A5]
.Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"
.Font.ColorIndex = 3
.Font.Italic = True
End With
strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _
& " Dim rng1 As Range" & vbCrLf _
& " Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _
& " If rng1 Is Nothing Then Exit Sub" & vbCrLf _
& " On Error Resume Next" & vbCrLf _
& " If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _
& " If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _
& "End Sub" & vbCrLf
Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)
vbCodeMod.CodeModule.AddFromString strWScode
End If
'tidy up Application settins
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
ErrHandler:
If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"
End Sub
Jump Sheet
Sub JumpSheet()
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sheets(1).[a1].Value)
On Error GoTo 0
If Not ws Is Nothing Then
Application.Goto ws.[a1]
Else
MsgBox "Sheet not found", vbCritical
End If
End Sub
Iterate over all sheets of the current workbook and activate the one with the right name. Here is some code which should give you the idea, You can put this in the code section of your search sheet and associate it with the "Clicked" event of a button.
Option Explicit
Sub Search_Click()
Dim sheetName As String, i As Long
sheetName = Range("A1")
For i = 1 To ThisWorkbook.Sheets.Count
If ThisWorkbook.Sheets(i).Name = sheetName Then
ThisWorkbook.Sheets(i).Activate
Exit For
End If
Next
End Sub
I am just confused about the question. Are you trying to open Workbook or Worksheet?.
If you trying to navigate to worksheet with in workbook,
E.g.
Worksheets("Sheet2").Activate

Resources