How can I get this to run complete? - excel

I have a VBA Macro Code for Excel 2016 that just does not want to go to the next step. What I am trying to do here is
bulk insert <10 CSV files into Separate Sheets (which does work) and;
then once the time out box closes or you press OK, select the first sheet and then delete it, and;
then merge the rest of the sheets into one.
The code is below (sorry it is a long one), and I have highlighted the section that is not 'working' for me. The code in fact stops after the time out box, and will not continue.
Sub Combine()
MsgBox "Please follow the following guidelines" & vbCr & "» Please make sure that all sheets are included in this workbook, and that you have clicked on cell 'A1' before continuing" & vbCr & "» Do not interrupt the process" & vbCr & "» Do not change the Macro code" & vbCr & "» Do not save over this Template." & vbCr & " If you need to save this file, please go File » Save As.", vbOKOnly + vbExclamation, Title:="IMPORTANT INFORMATION!"
MsgBox "The Front sheet will be deleted." & vbCr & "This is to simply create one sheet file. You will not need need this after the process has completed" & vbCr & vbCr & "Please press 'OK' to continue." & vbCr & "This cannot be undone!", vbOKOnly + vbCritical
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="CSV; XLS; XLSX; XLSM; TEXT; (*.csv;*.xls;*.xlsx;*.xlsm;*.txt),*.csv;*.xls;*.xlsx;*.xlsm;*.txt", Title:="Choose Excel files to Merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
'Set the message box to close after 10 seconds
AckTime = 5
Select Case InfoBox.Popup("Processed" & countFiles & " files." & vbCr & "(this window closes automatically after 5 seconds).", _
AckTime, "Excel File Merger", 0)
Case 1, -1
Exit Sub
End Select
Range("A1").Select
Worksheets("Cover").Delete
MsgBox "Cover Sheet has now been deleted. The rest of the code will continue.", vbOKOnly + vbInformation
Dim i As Integer
Dim xTCount As Variant
Dim xWs As Worksheet
On Error Resume Next
LInput:
xTCount = Application.InputBox("The number of title rows", "Please enter the amount of rows that are Titles or Table Headers", "1")
If TypeName(xTCount) = "Boolean" Then Exit Sub
If Not IsNumeric(xTCount) Then
MsgBox "Only can enter number", , "Error in input"
GoTo LInput
End If
Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
xWs.Name = "Combined"
Worksheets(2).Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
For i = 2 To Worksheets.Count
Worksheets(i).Range("A1").CurrentRegion.Offset(CInt(xTCount), 0).Copy _
Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, 1)
Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Combined" And xWs.Name <> "Combined" Then
xWs.Delete
End If
Next
ActiveSheet.ListObjects.Add(SourceType:=xlSrcRange, _
Source:=Selection.CurrentRegion, _
xlListObjectHasHeaders:=xlYes _
).Name = "DataTable"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Treatment Strategy Stage"
Range("A1").Select
MsgBox "Procesed - all Sheets are now Merged and filtered." & vbCr & "Thank you for your patience", Title:="Merge Excel Sheets"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub

If I understand correctly, you never want to exit the sub so change this
Select Case InfoBox.Popup("Processed" & countFiles & " files." & vbCr & "(this window closes automatically after 5 seconds).", _
AckTime, "Excel File Merger", 0)
Case 1, -1
Exit Sub
End Select
to this
Call InfoBox.Popup("Processed" & countFiles & " files." & vbCr & _
"(this window closes automatically after 5 seconds).", _
AckTime, "Excel File Merger", 0)

Related

Excel for Mac- Converting tested windows Excel macro to Mac

I am a newbie to macros but I was able to find and modify a macro to works for what I needed. The macro is for a Form that once filled out the user will push the "Save and email" button and the following will happen:
save location window will open, the file will be converted and saved as .pdf (the file name is predetermined based on cells information)
the active sheet will be converted to .pdf it will be attached to an email.
I was very proud of my achievement until I tested it on my Mac and realized that it will not work. Now, I am faced with a challenge of converting the macro from Windows to Mac in order for the keep the functionality of the Form.
Below is the tested code on a Windows Excel:
Sub Button9_Click()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object, signature As String
Dim xEmailObj As Object
Dim xUsedRng As Range
Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xFolder = xFolder + "\" + xSht.Range("G3").Text + ".pdf"
'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.Subject = ActiveWorkbook.Sheets("FORM").Range("G3")
.To = "name"
.CC = " "
.body = "Hi ..," & vbLf & vbLf _
& "The Parts Request Form is attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf & vbLf _
& Application.UserName & vbLf & vbLf _
& "..." & vbLf _
& "..., ..." & vbLf _
& "..." & vbLf _
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub

How can I stop a read-only file causing an infinite VBA loop?

novice here who usually finds his way with trial & error but coming up stumped here.
I have a loop that goes through files in a folder and copies data from each file and in to a master.
As each files are working documents there is a chance another user could have one of these files open so I am trying to negate past a file when it is read-only.
I've tried a filecounter not sure I'm grasping it!
Sub Pull_Decisions()
Dim x As Workbook, y As Workbook
Dim folderPath As String, path As String
Dim StartTime As Double, SecondsElapsed As Double
Dim fileCounter As Integer
'Remember time when macro starts
StartTime = Timer
'Removes filters to allow all data to be shown and reduce risk of overwriting data
On Error Resume Next
ActiveSheet.ShowAllData
'message to prompt user to check filter
filterCheck = MsgBox("Please check all filters are cleared before proceeding. Do you want to proceed?", vbYesNo)
Application.Visible = False 'Hides Excel whilst Macro Running
'Application.Visible = True
If filterCheck = vbYes Then
Application.ScreenUpdating = False
'Set this workbook as x workbooks
Set x = ThisWorkbook
x.Worksheets(1).range("K5").Value = Format(Now(), "dd/mm/yyyy hh:mm:ss") 'Update refresh time
If x.ReadOnly Then
Application.ScreenUpdating = True
y.Close 'close master workbook
MsgBox "Decision Submissions spreadsheet is in read only mode and cannot refresh. Please reopen in write mode to refresh table."
Application.Visible = True
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Exit Sub
End If
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "PATH TO REQUIRED FOLDER"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsm*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set y = ThisWorkbook
Set ws2 = y.Sheets("Allsubmissions")
'Loop through each Excel file in folder
Do While myFile <> "" Or fileCounter = 50
fileCounter = fileCounter + 1
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
If wb.ReadOnly Then 'If someone is in the workbook, the file will open as read only.
Application.ScreenUpdating = True
wb.Close
'MsgBox " Workbook is currently in use, please try again shortly"
Else
'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook
With wb.Sheets("Decisions")
lRow = .range("A" & Rows.Count).End(xlUp).Row
.range("A2:I2" & lRow).Copy ws2.range("A" & Rows.Count).End(xlUp)(2)
.range("A2:I2" & lRow).Delete
End With
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
End If
Loop
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Else
'If person wants to abort the refresh to clear the filter (shouldn't be required due to above code)
MsgBox "refresh aborted"
Application.Visible = True
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Exit Sub
End If
Application.Visible = True 'Makes excel visible again
'Determine how many seconds code took to run and notifies user
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
y.Save
End Sub
Ideally, i'd also like the folder to be pre-defined and not use "FldrPicker", but when i try this the code runs but nothing copies.
Sorry for the long post and would appreciate any help!
Option Explicit
Sub Pull_Decisions()
Const FOLDER = "C:\temp\so\70786709\"
Const EXT = "*.xlsm*"
Const LIMIT = 50 ' max files
Dim wbMaster As Workbook, wb As Workbook
Dim wsAll As Worksheet
Dim filecount As Long, lastrow As Long, total As Long
Dim myfile As String, ro As String, msg As String
Dim t0 As Single: t0 = Timer
Set wbMaster = ThisWorkbook
If wbMaster.ReadOnly Then
MsgBox "This workbook is in read only mode and cannot refresh. " & vbLf & _
"Please reopen in write mode to refresh table.", vbCritical, "Read Only"
wbMaster.Close
Exit Sub
End If
' prepare sheet
Set wsAll = wbMaster.Sheets("Allsubmissions")
wsAll.AutoFilterMode = False ' remove autofilter
wsAll.Range("K5").Value = Format(Now(), "dd/mm/yyyy hh:mm:ss")
' scan files in folder
myfile = Dir(FOLDER & EXT)
Application.ScreenUpdating = False
Do While myfile <> ""
filecount = filecount + 1
If filecount > LIMIT Then
MsgBox "File count > " & LIMIT, vbCritical
Exit Sub
End If
Set wb = Workbooks.Open(Filename:=FOLDER & myfile)
'If someone is in the workbook, the file will open as read only.
If wb.ReadOnly Then
ro = ro & vbLf & myfile ' store for later
wb.Close
Else
'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook ???
With wb.Sheets("Decisions")
lastrow = .Range("A" & .Rows.count).End(xlUp).Row
If lastrow > 1 Then
total = total + lastrow - 1
.Range("A2:I" & lastrow).Copy wsAll.Range("A" & Rows.count).End(xlUp).Offset(1)
.Range("A2:I" & lastrow).Delete
wb.Close SaveChanges:=True
Else
wb.Close SaveChanges:=False
End If
End With
End If
'Get next file name
myfile = Dir
Loop
Application.ScreenUpdating = True
' result
msg = total & " lines from " & filecount & " files." & vbLf
If Len(ro) > 0 Then
MsgBox msg & "These files were readonly; " & ro & vbLf & "Try again later.", vbExclamation, "Total = " & total
Else
MsgBox msg, vbInformation, Format(Timer - t0, "0.0 secs")
End If
End Sub

Excel MailMerge Export to PDF

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.

Programmatically Install Add-In VBA

I'm looking to create a macro that'll install an add-in for the user to the excel ribbon. I'm upto:
Private Sub Workbook_Open()
On Error Resume Next
Application.AddIns("Name of Addin").Installed = False
On Error GoTo 0
With Application
.AddIns.Add "Filepath to addin in shared location", False
.AddIns("Name of Addin").Installed = True
End With
ThisWorkbook.Close False
End Sub
Once running the macro, the addin installs to the ribbon no problems. The issue is, once excel is closed down, the addin no longer shows in the ribbon.
It would appear that excel is expecting the addin to be copied into the users C:\Documents and Settings\Username\Application Data\Microsoft\AddiIns folder as it throws the error that it can't find it when starting excel after closing down.
Now my understanding is that the second (false) variable for the line of code below basically says that the addin shouldn't be copied to the AddIns directory and rather should stay in the shared location.
.AddIns.Add "Filepath to addin in shared location", False
Any ideas on why Excel is expecting the addin to be in the users default folder?
I'll give it a try. Please see comments in code.
ThisWorkbook
Option Explicit
'
'---------------------------------------------------------------------
' Purpose : Call for installation as an addin if not installed
'---------------------------------------------------------------------
'
Private Sub Workbook_Open()
Dim AddinTitle As String, AddinName As String
Dim XlsName As String
AddinTitle = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
XlsName = AddinTitle & ".xlsm"
AddinName = AddinTitle & ".xla"
'check the addin's not already installed in UserLibraryPath
If Dir(Application.UserLibraryPath & AddinName) = Empty Then
'ask if user wants to install now
If MsgBox("Install " & AddinTitle & _
" as an add-in?", vbYesNo, _
"Install?") = vbYes _
Then
Run "InstallAddIn"
End If
Else
If ThisWorkbook.Name = XlsName Then
Run "ReInstall"
End If
End If
End Sub
'
'---------------------------------------------------------------------
' Purpose : Actuate the addin, add custom controls
'---------------------------------------------------------------------
'
Private Sub Workbook_AddinInstall()
Run "AddButtons"
End Sub
'
'---------------------------------------------------------------------
' Purpose : Deactivate the addin, remove custom controls
'---------------------------------------------------------------------
'
Private Sub Workbook_AddinUninstall()
Run "RemoveButtons"
End Sub
Module
Option Explicit
'
'---------------------------------------------------------------------
' Purpose : Convert .xls file to .xla, move it to
' addins folder, and install as addin
'---------------------------------------------------------------------
'
Private Sub InstallAddIn()
Dim AddinTitle As String, AddinName As String
Dim XlsVersion As String, MessageBody As String
With ThisWorkbook
AddinTitle = Left(.Name, Len(.Name) - 4)
AddinName = AddinTitle & ".xlam"
XlsVersion = .FullName '< could be anywhere
'check the addin's not installed in
'UserLibraryPath (error handling)
If Dir(Application.UserLibraryPath & AddinName) = Empty Then
.IsAddin = True '< hide workbook window
'move & save as .xla file
.SaveAs Application.UserLibraryPath & AddinName, 55
'go thru the add-ins collection to see if it's listed
If Listed Then
'check this addins checkbox in the addin dialog box
AddIns(AddinTitle).Installed = True '<--Error happening if .xlam format
Else
'it's not listed (not previously installed)
'add it to the addins collection
'and check this addins checkbox
AddIns.Add(ThisWorkbook.FullName, True) _
.Installed = True
End If
'inform user...
MessageBody = AddinTitle & " has been installed - " & _
"to access the tools available in" & _
vbNewLine & _
"this addin, you will find a button in the 'Tools' " & _
"menu for your use"
If BooksAreOpen Then '< quit if no other books are open
.Save
MsgBox MessageBody & "...", , AddinTitle & _
" Installation Status..."
Else
If MsgBox(MessageBody & " the" & vbNewLine & _
"next time you open Excel." & _
"" & vbNewLine & vbNewLine & _
"Quit Excel?...", vbYesNo, _
AddinTitle & " Installation Status...") = vbYes Then
Application.Quit
Else
.Save
End If
End If
End If
End With
End Sub
'---------------------------------------------------------------------
' Purpose : Checks if this addin is in the addin collection
'---------------------------------------------------------------------
'
Private Function Listed() As Boolean
Dim Addin As Addin, AddinTitle As String
Listed = False
With ThisWorkbook
AddinTitle = Left(.Name, Len(.Name) - 4)
For Each Addin In AddIns
If Addin.Title = AddinTitle Then
Listed = True
Exit For
End If
Next
End With
End Function
'---------------------------------------------------------------------
' Purpose : Check if any workbooks are open
' (this workbook & startups excepted)
'---------------------------------------------------------------------
'
Private Function BooksAreOpen() As Boolean
'
Dim Wb As Workbook, OpenBooks As String
'get a list of open books
For Each Wb In Workbooks
With Wb
If Not (.Name = ThisWorkbook.Name _
Or .Path = Application.StartupPath) Then
OpenBooks = OpenBooks & .Name
End If
End With
Next
If OpenBooks = Empty Then
BooksAreOpen = False
Else
BooksAreOpen = True
End If
End Function
'---------------------------------------------------------------------
' Purpose : Replace addin with another version if installed
'---------------------------------------------------------------------
'
Private Sub ReInstall()
Dim AddinName As String
With ThisWorkbook
AddinName = Left(.Name, Len(.Name) - 4) & ".xla"
'check if 'addin' is already installed
'in UserLibraryPath (error handling)
If Dir(Application.UserLibraryPath & AddinName) = Empty Then
'install if no previous version exists
Call InstallAddIn
Else
'delete installed version & replace with this one if ok
If MsgBox(" The target folder already contains " & _
"a file with the same name... " & _
vbNewLine & vbNewLine & _
" (That file was last modified on: " & _
Workbooks(AddinName) _
.BuiltinDocumentProperties("Last Save Time") & ")" & _
vbNewLine & vbNewLine & vbNewLine & _
" Would you like to replace the existing file with " & _
"this one? " & _
vbNewLine & vbNewLine & _
" (This file was last modified on: " & _
.BuiltinDocumentProperties("Last Save Time") & ")", _
vbYesNo, "Add-in Is In Place - " & _
"Confirm File Replacemant...") = vbYes Then
Workbooks(AddinName).Close False
Kill Application.UserLibraryPath & AddinName
Call InstallAddIn
End If
End If
End With
End Sub
'---------------------------------------------------------------------
' Purpose : Convert .xla file to .xls format
' and move it to default file path
'---------------------------------------------------------------------
'
Private Sub RemoveAddIn()
Dim AddinTitle As String, AddinName As String
Dim XlaVersion As String
Application.ScreenUpdating = False
With ThisWorkbook
AddinTitle = Left(.Name, Len(.Name) - 4)
AddinName = AddinTitle & ".xla"
XlaVersion = .FullName
'check the 'addin' is not already removed
'from UserLibraryPath (error handling)
If Not Dir(Application.UserLibraryPath & AddinName) = Empty _
Then
.Sheets(1).Cells.ClearContents '< cleanup
Call RemoveButtons
'move & save as .xls file
.SaveAs Application.DefaultFilePath & _
"\" & AddinTitle & ".xls"
Kill XlaVersion '< delete .xla version
'uncheck checkbox in the addin dialog box
AddIns(AddinTitle).Installed = False
.IsAddin = False '< show workbook window
.Save
'inform user and close
MsgBox "The addin '" & AddinTitle & "' has been " & _
"removed and converted to an .xls file." & _
vbNewLine & vbNewLine & _
"Should you later wish to re-install this as " & _
"an addin, open the .xls file which" & _
vbNewLine & "can now be found in " & _
Application.DefaultFilePath & _
" as: '" & .Name & "'"
.Close
End If
End With
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------
' Purpose : Add addin control buttons
'---------------------------------------------------------------------
'
Private Sub AddButtons()
'change 'Startups...' to suit
Const MyControl As String = "Startups..."
'change 'Manage Startups' to suit
Const MyControlCaption As String = "Manage Startups"
Dim AddinTitle As String, Mybar As Object
AddinTitle = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
Call RemoveButtons
On Error GoTo ErrHandler
Set Mybar = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls _
.Add(Type:=msoControlPopup, before:=13)
'
With Mybar
.BeginGroup = True
.Caption = MyControl
'-------------------------------------------------------------
.Controls.Add.Caption = MyControlCaption
.Controls(MyControlCaption).OnAction = "ShowStartupForm"
'-------------------------------------------------------------
With .Controls.Add
.BeginGroup = True
.Caption = "Case " & AddinTitle
End With
.Controls("Case change " & AddinTitle).OnAction = "ULCase.UpperMacro"
'-------------------------------------------------------------
.Controls.Add.Caption = "Remove " & AddinTitle
.Controls("Remove " & AddinTitle).OnAction = "Module1.RemoveAddIn"
'-------------------------------------------------------------
End With
Exit Sub
ErrHandler:
Set Mybar = Nothing
Set Mybar = Application.CommandBars("Tools") _
.Controls.Add(Type:=msoControlPopup, before:=13)
Resume Next
End Sub
'
'---------------------------------------------------------------------
' Purpose : Remove addin control buttons
'---------------------------------------------------------------------
'
Private Sub RemoveButtons()
'
'change 'Startups...' to suit
Const MyControl As String = "Startups..."
On Error Resume Next
With Application
.CommandBars("Tools").Controls(MyControl).Delete
.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls(MyControl).Delete
End With
End Sub

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