What I'm doing often requires that I have a bunch of Excel files open for
vlookups. Every time, I have to open each one. I never use the 'File>Save
Workspace' option because 'workspace' doesn't remember the formatting of the
workbooks and that causes as much of a pain as opening each one individually.
So, yesterday, being the lazy person I am, I got fed up with all that
extra work and wrote my own 'workspace' macro. (see below). The main macro
is OpenWorkspace.
It creates a list of all of your currently open files (not hidden
workbooks or Add-ins) and lists them in the currently active workbook even if
that workbook is new and unsaved.
It then creates a command button (with a built-in macro) so that next time
you open this workbook, you can click on the button and it will automatically
open the other workbooks in the list.
Thought I'd share.
'MACRO BEGINS HERE
'/=======================================/
Public Sub OpenWorkspace()
'Creates 'Workspace' hyperlink listing
' - that is: all currently open visible workbooks
'Reason: the 'workspace' option does not format the files
' as they were originally saved.
'03/15/2006
Dim iWorkbooks As Integer, x As Integer, y As Integer
Dim strWkshtName As String
On Error GoTo Err_Sub
strWkshtName = _
"Workspace - " & Format(Now(), "yyyy-mmm-dd_hhmmam/pm")
'count number of sheets in workbook
iWorkbooks = Application.Workbooks.Count
If iWorkbooks < 1 Then
MsgBox "No Workbooks are currently open...."
Exit Sub
End If
'check that at least one workbook is visible
y = 0
For x = 1 To iWorkbooks
If Windows(Workbooks(x).name).Visible Then
y = 1
Exit For
End If
Next x
If y = 0 Then 'no visible workbooks found
MsgBox "No Workbooks are currently visible...."
Exit Sub
End If
Call CreateWorksheet(strWkshtName)
'add all open/visible workbooks to workspace list
On Error Resume Next
For x = 1 To iWorkbooks
If Windows(Workbooks(x).name).Visible Then
y = y + 1
ActiveCell.Offset(y, 0).value = _
Application.Workbooks(x).FullName
ActiveCell.Offset(y, 1).value = _
Application.Workbooks(x).Path
ActiveCell.Offset(y, 2).value = _
Application.Workbooks(x).name
ActiveCell.Offset(y, 3).value = _
Format(FileLen(Application.Workbooks(x).FullName) / 1024, "#,##0")
ActiveCell.Offset(y, 4).value = _
FileDateTime(Application.Workbooks(x).FullName)
'create hyperlink
ActiveSheet.Hyperlinks.Add _
Anchor:=ActiveCell.Offset(y, 0), _
Address:=Application.Workbooks(x).FullName
End If
Next x
Call FormatWksht
Exit_Sub:
Exit Sub
Err_Sub:
GoTo Exit_Sub
End Sub
'/=======================================/
Private Sub CreateWorksheet(strWkshtName)
'create the worksheet that contains the 'workspace' list
'called from OpenWorkspace()
On Error Resume Next
'if worksheet exists, delete it
Application.DisplayAlerts = False
Application.Worksheets(strWkshtName).Delete
Application.DisplayAlerts = True
'create worksheet at end of workbook
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
ActiveSheet.name = strWkshtName
ActiveCell.Offset(0, 0).value = "Hyperlink"
ActiveCell.Offset(0, 1).value = "Path"
ActiveCell.Offset(0, 2).value = "Name"
ActiveCell.Offset(0, 3).value = "Size/kb"
ActiveCell.Offset(0, 4).value = "Date/Time"
End Sub
'/=======================================/
Private Sub FormatWksht()
'format the worksheet that contains the 'workspace' list
'called from OpenWorkspace()
Columns("B:E").EntireColumn.AutoFit
Range("A2").Select
ActiveWindow.Zoom = 75
ActiveWindow.FreezePanes = True
Call CreateButton
End Sub
'/=======================================/
Private Sub CreateButton()
'creates button that user can left-click to open all
' workbooks in the workspace list
'called from FormatWksht()
Dim btn As Button
Dim iCodeLine As Integer, iStartLine As Integer
Dim cmWorkSpace As Object 'CodeModule
Dim rng As Range
Dim strCodeName As String
Dim varAnswer As Variant
On Error Resume Next
Set rng = Range("F1")
'format cell
With rng
.FormulaR1C1 = "Click HERE to Load all Workspace workbooks"
.Font.Bold = True
.EntireColumn.AutoFit
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
.Font.ColorIndex = 3
With .Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End With
'create procedure that button will use in 'OnAction'
Call CreateOpenWorkbooksInWorkspaceModule
'create button
Set btn = ActiveSheet.Buttons.Add(0, 0, 0, 0)
With btn
.Top = rng.Offset(0, 0).Top
.Left = rng.Offset(0, 0).Left
.Width = rng.Offset(0, 0).Width
.Height = rng.Offset(0, 0).Height
.name = "cmdOpenWorkbooks"
.Caption = rng.value
.Characters.Text = "Click HERE to Load all Workspace workbooks"
With .Characters(Start:=1, Length:=10).Font
.FontStyle = "Bold"
.ColorIndex = 5
End With
.ShapeRange.LockAspectRatio = msoTrue
.Placement = xlMove
.PrintObject = True
.Visible = True
'tell button what to do when it is left-clicked
' ie: what macro to run
.OnAction = _
ActiveWorkbook.name & "!" & _
"OpenWorkbooksInWorkspace"
'if workbook needs to be saved, give user option of doing it now
If ActiveWorkbook.Saved = False Then
varAnswer = _
MsgBox("File should be saved...", _
vbCritical + vbOKCancel, "Optional but Recommended...")
If varAnswer = vbOK Then
Application.Dialogs(xlDialogSaveAs).Show
End If
End If
End With
Exit_Sub:
On Error Resume Next
Set btn = Nothing
Set rng = Nothing
Set cmWorkSpace = Nothing
Exit Sub
End Sub
'/=======================================/
Private Sub CreateOpenWorkbooksInWorkspaceModule()
'create a module that is run by the on-the-fly button
' - created in workbook where workspace list is located
'called from CreateButton()
Dim iCodeLine As Long
Dim objVBComponent As Object, objVBCodeModule As Object
Dim strVBComponent As String, strVBCodeModule As String
On Error GoTo Err_Sub
strVBComponent = "Mod_OpenWrkbksInWkspace"
strVBCodeModule = "OpenWorkbooksInWorkspace"
'create Standard Module = vbext_ct_StdModule = 1
Set objVBComponent = _
Application.ActiveWorkbook.VBProject.VBComponents.Add(1)
objVBComponent.name = strVBComponent
'create the procedure in the module
Set objVBCodeModule = _
Application.ActiveWorkbook.VBProject. _
VBComponents(strVBComponent).CodeModule
With objVBCodeModule
iCodeLine = .CountOfLines + 1
.InsertLines iCodeLine, _
"Public Sub OpenWorkbooksInWorkspace()"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" Dim x As Integer"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" Dim strCurrentWorkbook As String"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" On Error Resume Next"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" Range(" & Chr(34) & "A2" & Chr(34) & ").Select"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" strCurrentWorkbook = Application.ActiveWorkbook.Name"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" ActiveWindow.WindowState = xlMaximized"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" x = 0"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" Do While Len(ActiveCell.Offset(x, 0).Value) <> 0"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" ActiveCell.Offset(x, 0).Hyperlinks(1).Follow NewWindow:=True"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" x = x + 1"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" Application.Workbooks(strCurrentWorkbook).Activate"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" ActiveWindow.WindowState = xlMaximized"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
" Loop"
iCodeLine = iCodeLine + 1
.InsertLines iCodeLine, _
"End Sub"
End With
Exit_Sub:
On Error Resume Next
Set objVBCodeModule = Nothing
Set objVBComponent = Nothing
Exit Sub
Err_Sub:
GoTo Exit_Sub
End Sub
'/=======================================/
HTH,