I've been working on a macro that will add an image into a cell if the cell contains an image name (image1.png) that is in a specified directory. So if it finds "image1.png" in the directory it adds the image to the cell and moves to the next row. Here is the code thus far:
Option Explicit
Sub insertPicss()
Dim ws As Worksheet, cell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim fPath, fDir As String
fDir = "Macintosh HD:Users:Connor:Desktop:siteimages:"
For Each cell In ws.[A1:A12]
fPath = fDir & cell.Value
With ws.Pictures.Insert(fPath)
With .ShapeRange
.Width = 48
.Height = 48
End With
.PrintObject = True
.Top = cell.Top
.Left = cell.Left
End With
Next
End Sub
The issue it stops at a row that does not have an image name that is located in the directory it is looking at.
Is there a way to skip the row if it doesn't have that image in the corresponding directory and make it to the end of all the rows.
In Windows, use Dir to check if a file/folder exists.
Below works for Windows, but not sure about Mac.
Option Explicit
Sub insertPicss()
Dim ws As Worksheet, cell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim fPath, fDir As String
fDir = "Macintosh HD:Users:Connor:Desktop:siteimages:"
For Each cell In ws.[A1:A12]
fPath = fDir & cell.Value
If Dir(fPath) = cell.Value Then ' If Not Dir(fPath) = "" Then
With ws.Pictures.Insert(fPath)
With .ShapeRange
.Width = 48
.Height = 48
End With
.PrintObject = True
.Top = cell.Top
.Left = cell.Left
End With
End If
Next
End Sub
Related
My sheet has three columns, "A" = Images, "B" = Image Names, and "C" = URL Links, with Rows 1 and 2 being used as headers and rows 3 to 1002 for user input. The Current working code will search for the image names in Column "B" in the folder you select, and inserts them into Column "A". This macro runs off of a commandbutton I have placed on a userform I have created.
Working code is as follows (this is a edited version of the accepted answer here):
Private Sub Add_Images_Click()
Const EXIT_TEXT As String = ""
Const NO_PICTURE_FOUND As String = "No picture found"
Dim picName As String
Dim picFullName As String
Dim rowIndex As Long
Dim lastRow As Long
Dim selectedFolder As String
Dim data() As Variant
Dim wks As Worksheet
Dim Cell As Range
Dim pic As Picture
On Error GoTo ErrorHandler
selectedFolder = GetFolder
If Len(selectedFolder) = 0 Then GoTo ExitRoutine
Application.ScreenUpdating = False
Set wks = ActiveSheet
lastRow = wks.Cells(2, "B").End(xlDown).Row
data = wks.Range(wks.Cells(3, "B"), wks.Cells(lastRow, "B")).Value2
For rowIndex = 3 To UBound(data, 1)
If StrComp(data(rowIndex, 1), EXIT_TEXT, vbTextCompare) = 0 Then GoTo ExitRoutine
picName = data(rowIndex, 1)
picFullName = selectedFolder & picName
If Len(Dir(picFullName)) > 0 Then
Set Cell = wks.Cells(rowIndex, "A")
Set pic = wks.Pictures.Insert(picFullName)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Cell.Height
.Width = Cell.Width
.Top = Cell.Top
.Left = Cell.Left
.Placement = xlMoveAndSize
End With
Else
wks.Cells(rowIndex, "A").Value = NO_PICTURE_FOUND
End If
Next rowIndex
ExitRoutine:
Set wks = Nothing
Set pic = Nothing
Application.ScreenUpdating = True
UserForm.Hide
Exit Sub
ErrorHandler:
MsgBox Prompt:="Unable to find photo", _
Title:="An error occured", _
Buttons:=vbExclamation
Resume ExitRoutine
End Sub
Private Function GetFolder() As String
Dim selectedFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Select the folder containing the Image/PDF files."
.Show
If .SelectedItems.count > 0 Then
selectedFolder = .SelectedItems(1)
If Right$(selectedFolder, 1) <> Application.PathSeparator Then _
selectedFolder = selectedFolder & Application.PathSeparator
End If
End With
GetFolder = selectedFolder
End Function
I'm looking for a way to edit this macro so that it would be able to use the URL links for the images in Column "C" and find and insert the images into Column "A" that way. I found a working code (can't remember where, or I'd link it) that I tried to adapt with my current code to achieve the desired results.
The sample code I found online:
Sub Images_Via_URL()
Dim url_column As Range
Dim image_column As Range
Set url_column = Worksheets(1).UsedRange.Columns("A")
Set image_column = Worksheets(1).UsedRange.Columns("B")
Dim i As Long
For i = 2 To url_column.Cells.Count
With image_column.Worksheet.Pictures.Insert(url_column.Cells(i).Value)
.Left = image_column.Cells(i).Left
.Top = image_column.Cells(i).Top
.Height = 100
.Width = 100
End With
Next
End Sub
The following code is my failed attempt to edit it myself. It worked once for a list of 7 URL links, then I deleted one of the links in the middle to see if it would handle the blank cell correctly, and now it flat out wont work. It goes into the "ExitRoutine" every time.
Not Working Code:
Option Explicit
Private Sub URL_Images_Click()
Const EXIT_TEXT As String = ""
Const NO_PICTURE_FOUND As String = "No picture found"
Dim picURL As String
Dim rowIndex As Long
Dim lastRow As Long
Dim data() As Variant
Dim wks As Worksheet
Dim Cell As Range
Dim pic As Picture
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Set wks = ActiveSheet
lastRow = wks.Cells(2, "B").End(xlDown).Row
data = wks.Range(wks.Cells(3, "C"), wks.Cells(lastRow, "C")).Value2
For rowIndex = 3 To UBound(data, 1)
**If StrComp(data(rowIndex, 1), EXIT_TEXT, vbTextCompare) = 0 Then GoTo ExitRoutine**
picURL = data(rowIndex, 1)
If Len(picURL) > 0 Then
Set Cell = wks.Cells(rowIndex, "A")
Set pic = wks.Pictures.Insert(picURL)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Cell.Height
.Width = Cell.Width
.Top = Cell.Top
.Left = Cell.Left
.Placement = xlMoveAndSize
End With
Else
wks.Cells(rowIndex, "A").Value = NO_PICTURE_FOUND
End If
Next rowIndex
ExitRoutine:
Set wks = Nothing
Set pic = Nothing
Application.ScreenUpdating = True
UserForm.Hide
Exit Sub
ErrorHandler:
MsgBox Prompt:="Unable to find photo", _
Title:="An error occured", _
Buttons:=vbExclamation
Resume ExitRoutine
End Sub
I've bolded the line that is forcing it to the "ExitRoutine". I'm not sure how exactly that line works as I am not the one who originally wrote it. Any help would be great!
lastRow = wks.Cells(2, "B").End(xlDown).Row
data = wks.Range(wks.Cells(3, "C"), wks.Cells(lastRow, "C")).Value2
For rowIndex = 3 To UBound(data, 1)
'....
If you start at rowIndex = 3 then you're skipping the first two rows of your input data: a 2-D array from a range always has lower bounds of 1 for both dimensions, regardless of the location of the range.
In this case data(1,1) will correspond to C3, whereas data(3,1) is C5
I have the following working codes.
Column B has image names, this pulls images in the selected folder that match the names in column B and inserts them into Column A (please note, first two rows are used for my header). I've noticed that the code errors if the header in B2 is missing, then the code errors out. I would like to fix this so it will only try to find images if there is a name in Range("B3:B1002").
Option Explicit
Private Sub Add_Images_Click()
Const EXIT_TEXT As String = ""
Const NO_PICTURE_FOUND As String = "No picture found"
Dim picName As String
Dim picFullName As String
Dim rowIndex As Long
Dim lastRow As Long
Dim selectedFolder As String
Dim data() As Variant
Dim wks As Worksheet
Dim Cell As Range
Dim pic As Picture
On Error GoTo ErrorHandler
selectedFolder = GetFolder
If Len(selectedFolder) = 0 Then GoTo ExitRoutine
Application.ScreenUpdating = False
Set wks = ActiveSheet
lastRow = wks.Cells(2, "B").End(xlDown).Row
data = wks.Range(wks.Cells(1, "B"), wks.Cells(lastRow, "B")).Value2
For rowIndex = 3 To UBound(data, 1)
If StrComp(data(rowIndex, 1), EXIT_TEXT, vbTextCompare) = 0 Then GoTo ExitRoutine
picName = data(rowIndex, 1)
picFullName = selectedFolder & picName
If Len(Dir(picFullName)) > 0 Then
Set Cell = wks.Cells(rowIndex, "A")
Set pic = wks.Pictures.Insert(picFullName)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Cell.Height
.Width = Cell.Width
.Top = Cell.Top
.Left = Cell.Left
.Placement = xlMoveAndSize
End With
Else
wks.Cells(rowIndex, "A").Value = NO_PICTURE_FOUND
End If
Next rowIndex
ExitRoutine:
Set wks = Nothing
Set pic = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox Prompt:="Unable to find photo", _
Title:="An error occured", _
Buttons:=vbExclamation
Resume ExitRoutine
End Sub
This is the Function that has the user select the folder that contains the images when the above sub is ran. I would like to modify this if possible to also work with an URL like an FTP site. So if the images are in a folder on the users pc, it will run like below, but if the images are located in a FTP location, it will still be able to pull the images.
Private Function GetFolder() As String
Dim selectedFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Select the folder containing the Image/PDF files."
.Show
If .SelectedItems.Count > 0 Then
selectedFolder = .SelectedItems(1)
If Right$(selectedFolder, 1) <> Application.PathSeparator Then _
selectedFolder = selectedFolder & Application.PathSeparator
End If
End With
GetFolder = selectedFolder
End Function
This Sub is meant to remove all images from column A. The problem is that this works too well. It is fine when used with a normal button, but when I try using a CommandButton to have my buttons on a user form, this Sub removes the CommandButton. It also removes all comments from the sheet. I would like to either limit this to only remove images, or to quarantine the code to only look at Range("A3:A1002").
Private Sub Remove_Images_Click()
'Remove Images
Dim wks As Worksheet
Dim shp As Shape
Dim picArray() As String
Dim index As Integer
On Error GoTo ErrorHandler
Columns(1).Replace What:="No Picture Found", Replacement:=vbNullString, LookAt:=xlPart
Set wks = ActiveSheet
index = 1
For Each shp In wks.Shapes
If shp.Type <> msoFormControl Then
ReDim Preserve picArray(1 To index)
picArray(index) = shp.Name
index = index + 1
End If
Next shp
wks.Shapes.Range(picArray).Delete
ExitRoutine:
Set wks = Nothing
Set shp = Nothing
Erase picArray
Exit Sub
ErrorHandler:
MsgBox Prompt:="Unable to find photo", _
Title:="An error occured", _
Buttons:=vbExclamation
Resume ExitRoutine
End Sub
I see three main questions, probably better to separate these into different questions but I'll give it a shot.
Ignore row 2 in the first code block.
Change 1 to 3 on this line: data = wks.Range(wks.Cells(3, "B"), wks.Cells(lastRow, "B")).Value2 This sets your data range starting at row 3 and ignores your two header rows.
FTP link
This is better suited for a separate question. Start by creating a new function that handles FTP links. Then identify which path is in the cell, i.e. does it start with http, c://, etc... Then call appropriate function and have it return the image to the main program.
Check if shape is in column A.
Use the TopLeftCell attribute and see if it intersects column A
For Each shp In wks.Shapes
If Not Intersect(shp.TopLeftCell, Columns(1)) Is Nothing Then '<-- New Line checks if in col A
If shp.Type <> msoFormControl Then
....
I'm using the macro below to insert the picture corresponding to the value in Cell P2 into cell Q2.
This works for the one cell selected (P2 in this case).
I want to create a loop to do the same action for the rows in Column P range (P2:P500) that are not blank.
Sub Picture()
Range("Q2").Select
Dim picname As String
picname = "C:\Users\kisnahr\Pictures\Test\" & Range("P2") & ".bmp" 'Link to the picture
ActiveSheet.Pictures.Insert(picname).Select
With Selection
.Left = Range("Q2").Left
.Top = Range("Q2").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
Range("Q10").Select
Application.ScreenUpdating = True
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("P20").Select
End Sub
Try something along these lines. This is a very rough and ready solution, so you'll need to adapt it to your own requirements. Here I've put the image path in column B and is fired off from a CommandButton4 click. Not sure how you define your cell Left and Cell Top though?
Private Sub CommandButton4_Click()
Dim MyRange As String
Dim picname As String
Dim mySelectRange As String
Dim rcell As Range
Dim IntInstr As Integer
Dim Mypath As String
Mypath = "z:\My Pictures"
MyRange = "B2:B500"
Range(MyRange).Select
For Each rcell In Selection.Cells
If Len(rcell.value) > 0 Then
picname = Mypath & rcell.value
mySelectRange = Replace(MyRange, "B", "A")
IntInstr = InStr(mySelectRange, ":")
mySelectRange = Left(mySelectRange, IntInstr - 1)
do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
End If
Next
Application.ScreenUpdating = True
End Sub
Private Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
ActiveSheet.Pictures.Insert(picname).Select
On Error GoTo 0
With Selection
.Left = myleft
.Top = mytop
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub
I use following, so the sheet can be mailed etc. :
'Picname in Column B7 and corresponding picture in Column M7
Sub Picture()
Dim picname As String
Dim shp As Shape
Dim pasteAt As Integer
Dim lThisRow As Long
lThisRow = 7 'This is the start row
Do While (Cells(lThisRow, 2) <> "")
pasteAt = lThisRow
Cells(pasteAt, 13).Select 'This is where picture will be inserted (column)
picname = Cells(lThisRow, 2) 'This is the picture name
present = Dir("C:\foto\" & picname & ".jpg")
If present <> "" Then
Cells(pasteAt, 13).Select
Call ActiveSheet.Shapes.AddPicture("C:\foto\" & picname & ".jpg", _
msoCTrue, msoCTrue, Left:=Cells(pasteAt, 13).Left, Top:=Cells(pasteAt, 13).Top, Width:=100, Height:=100).Select
Else
Cells(pasteAt, 14) = "No Picture Found"
End If
lThisRow = lThisRow + 1
Loop
Range("A1").Select
Application.ScreenUpdating = True
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("O7").Select
End Sub
I have adapted the following code from Contextures website which adds combo box functionality into cells containing data validation. Though comboboxes display well where they should, I am still facing two issues.
First, I would need that after chosing value in "D4" cell, which combines data validation and combo box, the same value was displayed on other sheets in "D4" cell in the workbook. Unfortunately, after comboboxes code was added, the Workbook_SheetChange code stopped working. I assume it is because it cannot find Target in data validation/combobox cell now.
The second issue is that the Worksheet_SelectionChange code below causes screen flickering even though Application.ScreenUpdating is applied. Is there any way to get rid of it?
I would be greatful for any solutions.
EDIT:
At last I managed to find solution to first issue myself. I ommited Workbook_SheetChange event entirely and replaced with ComboShtHeader_KeyDown and ComboShtHeader_LostFocus events, both placed in the workbook sheets. These macros ensure that value of a cell changes on all sheets either on pressing Tab, Enter or click outside "D4" cell. I am placing both codes below for the case that someone faces similar issue.
The other issue with screen flickering in Worksheet_SelectionChange code persists though. Solutions are still welcome.:-)
Private Sub ComboShtHeader_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'change "D4" cell value on all sheets on pressing TAB or ENTER
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
Select Case KeyCode
Case 9 'Tab
ActiveCell.Offset(0, 1).Activate
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range(ActiveCell.Offset(0, -3).Address).Value = ActiveCell.Offset(0, -3).Value
End If
Next ws
Case 13 'Enter
ActiveCell.Offset(1, 0).Activate
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range(ActiveCell.Offset(-1, 0).Address).Value = ActiveCell.Offset(-1, 0).Value
End If
Next ws
Case Else
'do nothing
End Select
End Sub
Private Sub ComboShtHeader_LostFocus()
'change "D4" cell value on all sheets on click outside "D4" cell
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range("D4").Value = ws1.Range("D4").Value
End If
Next ws
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet, ws2 As Worksheet
Dim ComHead As OLEObject, ComBody As OLEObject
Dim Str As String
Application.ScreenUpdating = False
On Error GoTo ErrHandler
Set ws = ActiveSheet
Set ws2 = Worksheets("lists")
Set ComHead = ws.OLEObjects("ComboShtHeader")
Set ComBody = ws.OLEObjects("ComboShtBody")
On Error Resume Next
If ComHead.Visible = True Then
With ComHead
.Top = 34.5
.Left = 120
.Width = 20
.Height = 15
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
End If
On Error Resume Next
If ComBody.Visible = True Then
With ComBody
.Top = 34.5
.Left = 146.75
.Width = 20
.Height = 15
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
End If
On Error GoTo ErrHandler
'If the cell contains a data validation list
If Target.Validation.Type = 3 Then
If Target.Address = ws.Range("D4:F4").Address Then
If Target.Count > 3 Then GoTo ExitHandler
Application.EnableEvents = False
'Get the data validation formula
Str = Target.Validation.Formula1
Str = Right(Str, Len(Str) - 1)
With ComHead
'Show the combobox with the validation list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height
.ListFillRange = ws2.Range(Str).Address(external:=True)
.LinkedCell = Target.Address
End With
ComHead.Activate
'Open the dropdown list automatically
Me.ComboShtHeader.DropDown
Else
If Target.Count > 1 Then GoTo ExitHandler
Application.EnableEvents = False
'Get the data validation formula
Str = Target.Validation.Formula1
Str = Right(Str, Len(Str) - 1)
With ComBody
'Show the combobox with the validation list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height
.ListFillRange = ws2.Range(Str).Address(external:=True)
.LinkedCell = Target.Address
End With
ComBody.Activate
'Open the dropdown list automatically
Me.ComboShtBody.DropDown
End If
End If
ExitHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrHandler:
Resume ExitHandler
End Sub
The second code, placed in ThisWorkbook module and currently not working:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wb1 As Workbook
Dim ws1 As Worksheet, ws As Worksheet
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set wb1 = ThisWorkbook
Set ws1 = Sh
On Error GoTo LetsContinue
'This should change "D4" value on all sheets, but does not work after combobox feature was added to the sheets.
If Not Intersect(Target, ws1.Range("D4")) Is Nothing Then
MsgBox Target.Address 'returns nothing
For Each ws In wb1.Worksheets
If Target.Value <> ws.Range(Target.Address).Value Then
ws.Range(Target.Address).Value = Target.Value
End If
Next ws
Else
GoTo LetsContinue
End If
LetsContinue:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Actually, the second issue that regarded screen flickering solved itself when I moved from Excel 2007 to 2013 version. It seems like some kind of bug in older version.
Good Afternoon,
I never used VBA before so I really need your help!
I have following macro (my first ever) and it works fine but after testing with our district managers this file ("SalesOrderRMTOOL.xlsx") open with different name on their computers.
How can I change my macro to read only a partial name? It will always be SalesOrderRMTOOL but after it could be anything……?? Thank you for your help in advance
Private Sub CommandButton1_Click()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim wsTool As Worksheet
Dim wBook As Workbook
On Error Resume Next
Set wBook = Workbooks("SalesOrderRMTOOL.xlsx")
If wBook Is Nothing Then
MsgBox "Please open SaleOrderRMTOOL file"
Set wBook = Nothing
Exit Sub
End If
Set wsSource = Workbooks("SalesOrderRMTOOL.xlsx").Sheets("Salesorder")
Set wsTarget = Workbooks("RMORDERTOOL.xlsm").Sheets("Sales Order")
Application.ScreenUpdating = False
Workbooks("RMORDERTOOL.xlsm").Sheets("Tool").Range("i7:i1003").Value = ""
Workbooks("RMORDERTOOL.xlsm").Sheets("Tool").Range("l7:l1003").Value = ""
Workbooks("RMORDERTOOL.xlsm").Sheets("Tool").Range("o7:o1003").Value = ""
wsTarget.Cells.Clear
' Copy header row to Target sheet if target is empty
If IsEmpty(wsTarget.Range("A1")) Then wsSource.Rows(1).Copy Destination:=wsTarget.Range("A1")
' Define visible filterd cells on source worksheet and copy
With wsSource
.Range("A2", .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, .Cells(1, Columns.Count).End(xlToLeft).Column)).SpecialCells(xlCellTypeVisible).Copy
End With
' Paste to target sheet
wsTarget.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
Application.CutCopyMode = True
Application.ScreenUpdating = True
Workbooks("SalesOrderRMTOOL*.xlsx").Close 0
End Sub
I would create a short function to return the sales order workbook if it exists. At the top of the module with the function, I'd use a Constant (Const) to hold the beginning of the workbook name, in case it ever changes:
'Constant at top of module
Const WORKBOOK_NAME As String = "SalesOrderRMTOOL"
'Anywhere else in same module
Function GetSalesOrderWb() As Excel.Workbook
Dim wb As Excel.Workbook
For Each wb In Application.Workbooks
If Left(wb.Name, Len(WORKBOOK_NAME)) = WORKBOOK_NAME Then
Set GetSalesOrderWb = wb
Exit Function
End If
Next
End Function
Then call it like this:
Set wBook = GetSalesOrderWb
If wBook Is Nothing Then
MsgBox "Please open SaleOrderRMTOOL file"
Exit Sub
End If
You can make the person who will use this macro to select the Workbook he will use displaying a dialog like this:
Sub BrowseWorkbooks()
Const nPerColumn As Long = 38 'number of items per column
Const nWidth As Long = 13 'width of each letter
Const nHeight As Long = 18 'height of each row
Const sID As String = "___SheetGoto" 'name of dialog sheet
Const kCaption As String = " Select Workbook"
'dialog caption
Dim i As Long
Dim TopPos As Long
Dim iBooks As Long
Dim cCols As Long
Dim cLetters As Long
Dim cMaxLetters As Long
Dim cLeft As Long
Dim thisDlg As DialogSheet
Dim CurrentSheet As Worksheet
Dim cb As OptionButton
Application.ScreenUpdating = False
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.DialogSheets(sID).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set CurrentSheet = ActiveSheet
Set thisDlg = ActiveWorkbook.DialogSheets.Add
With thisDlg
.Name = sID
.Visible = xlSheetHidden
'sets variables for positioning on dialog
iBooks = 0
cCols = 0
cMaxLetters = 0
cLeft = 78
TopPos = 40
For i = 1 To Workbooks.Count
If i Mod nPerColumn = 1 Then
cCols = cCols + 1
TopPos = 40
cLeft = cLeft + (cMaxLetters * nWidth)
cMaxLetters = 0
End If
Set CurrentWorkbook = Workbooks(i)
cLetters = Len(CurrentWorkbook.Name)
If cLetters > cMaxLetters Then
cMaxLetters = cLetters
End If
iBooks = iBooks + 1
.OptionButtons.Add cLeft, TopPos, cLetters * nWidth, 16.5
.OptionButtons(iBooks).Text = _
Workbooks(iBooks).Name
TopPos = TopPos + 13
Next i
.Buttons.Left = cLeft + (cMaxLetters * nWidth) + 24
CurrentWorkbook.Activate
With .DialogFrame
.Height = Application.Max(68, _
Application.Min(iBooks, nPerColumn) * nHeight + 10)
.Width = cLeft + (cMaxLetters * nWidth) + 24
.Caption = kCaption
End With
.Buttons("Button 2").BringToFront
.Buttons("Button 3").BringToFront
Application.ScreenUpdating = True
If .Show Then
For Each cb In thisDlg.OptionButtons
If cb.Value = xlOn Then
'Store the name of the Woorkbook to use it later
SelectedWorkBookName = cb.Caption
Exit For
End If
Next cb
Else
MsgBox "Nothing selected"
End If
Application.DisplayAlerts = False
.Delete
End With
End Sub
Then use the SelectedWorkBookName variable to call the workbook like this:
Set wBook = Workbooks(SelectedWorkBookName)