FAQ 工作薄及工作表

列出所有工作薄的 VBA

由 Mr Colo写的 VBA 需要在VBA内选取 Microfost Visual Basic Applications Extensbility

请在 Tools - 宏 - 安全性 - 选取 信任存取 Visual Basic 项目

' Module
' List All VBA module
Dim x As Long
Dim aList()

Sub GetVbProj()
Dim oVBC As VBIDE.VBComponent
Dim Wb As Workbook
x = 2
For Each Wb In Workbooks
For Each oVBC In Workbooks(Wb.Name).VBProject.VBComponents
If Workbooks(Wb.Name).VBProject.Protection = vbext_pp_none Then
Call GetCodeRoutines(Wb.Name, oVBC.Name)
End If
Next
Next
With Sheets.Add
.[A1].Resize(, 3).Value = Array("Workbook", "Module", "Procedure")
.[A2].Resize(UBound(aList, 2), UBound(aList, 1)).Value = _
Application.Transpose(aList)
.Columns("A:C").Columns.AutoFit
End With
End Sub

Private Sub GetCodeRoutines(wbk As String, VBComp As String)
Dim VBCodeMod As CodeModule
Dim StartLine As Long

On Error Resume Next
Set VBCodeMod = Workbooks(wbk).VBProject.VBComponents(VBComp).CodeModule
With VBCodeMod
StartLine = .CountOfDeclarationLines + 1
Do Until StartLine >= .CountOfLines
ReDim Preserve aList(1 To 3, 1 To x - 1)
aList(1, x - 1) = wbk
aList(2, x - 1) = VBComp
aList(3, x - 1) = .ProcOfLine(StartLine, vbext_pk_Proc)
x = x + 1
StartLine = StartLine + .ProcCountLines(.ProcOfLine(StartLine, _
vbext_pk_Proc), vbext_pk_Proc)
If Err Then Exit Sub
Loop
End With
Set VBCodeMod = Nothing
End Sub

不可以选择或编辑单元格

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Myrange As Range, KeepOut As Range
Dim ws As Worksheet

'Full sheet
'Set KeepOut = ActiveSheet.Cells
'Several Columns
'Set KeepOut = ActiveSheet.Range("B:D")
'Test Range
Set KeepOut = ActiveSheet.Range("A2:C5")

Set Myrange = Intersect(Target, KeepOut)
'Leave if the intersecttion ws untouched
If Myrange Is Nothing Then Exit Sub

'Stop select firing a second time
Application.EnableEvents = False
If KeepOut.Rows.Count = 65536 And KeepOut.Columns.Count = 256 Then
'Entire sheet is the KeepOut range. Eek!
'Bounce user to a dummy sheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets("KickMeTo")
On Error GoTo 0
If ws Is Nothing Then
Set ws = ThisWorkbook.Sheets.Add
ws.Name = "KickMeTo"
End If
MsgBox "Houston we have a problem" & vbNewLine & _
"You cannot select any cell in " & vbNewLine & "'" & KeepOut.Parent.Name & "'" & vbNewLine & _
"So you have been directed to a different sheet"
ws.Activate
ElseIf KeepOut.Rows.Count = 65536 Then
'If all rows are contained in the "KeepOut" range then:
'Now we need to find a cell that is in a column to the right or left of this range
If KeepOut.Cells(1).Column > 1 Then
'If there is a valid column to the left of the range then select the cell in this column
Cells(KeepOut.Cells(1).Row, KeepOut.Cells(1).Column - 1).Select
Else
'Else select the cell in first column to the right of the range
Cells(KeepOut.Cells(1).Row, KeepOut.Cells(1).Column + 1).Select
End If
MsgBox "You cannot select " & KeepOut.Address(False, False) & vbNewLine & _
"You have been directed to the first free column in the protected range", vbCritical
ElseIf KeepOut.Rows.Count + KeepOut.Cells(1).Row - 1 = 65536 Then
'Select first cell in Column A before "KeepOut" Range
Cells(KeepOut.Cells(1).Row - 1, 1).Select
MsgBox "You cannot select " & KeepOut.Address(False, False) & vbNewLine & _
"You have been directed to the first free cell in Column A above the protected range", vbCritical
Else
'Select first cell in Column A beyond "KeepOut" Range
MsgBox "You cannot select " & KeepOut.Address(False, False) & vbNewLine & _
"You have been directed to the first free cell in Column A below the protected range", vbCritical
Cells(KeepOut.Rows.Count + KeepOut.Cells(1).Row, 1).Select
End If
Application.EnableEvents = True
End Sub

MicroSoft 沒有文件顯示 編碼 的大小限制
64K 太大，很難跟進

以下編碼檢示 Module 的大小

Sub get_Mod_Size()
Dim myProject As Object
Dim ComName As String
Dim tempPath As String
Dim fs As Object, a As Object
Dim result As String

' **************************************************************************************
' Use this to determine the size of a module
' Set ModName (component name) and tempPath (where to store the temp fule), then run
' **************************************************************************************

' Set these to run
ComName = "Module1"
tempPath = "c:\Test.bas"

' ***** No action needed after this point *****

' Export the component (module, form, etc) - this is only temporary
Set myProject = Application.VBE.ActiveVBProject.VBComponents
myProject(ComName).Export (tempPath)

' Get the size of the file created
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.getfile(tempPath)
result = ComName & " uses " & (a.Size / 1000) & " KB."

' Return the file size
MsgBox result, vbExclamation

' Delete the exported file
fs.Deletefile tempPath

End Sub

测试 WorkSheet 是否存在

Sub IsSheetExist()
Dim wSheet As Worksheet
On Error Resume Next
Set wSheet = Sheets("Sheet6")
If wSheet Is Nothing Then
MsgBox "Worksheet does not exist"
Set wSheet = Nothing
On Error GoTo 0
Else
MsgBox "Sheet does exist"
Set wSheet = Nothing
On Error GoTo 0
End If
End Sub

让工作表始终置顶

----------------- Module

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE

Public Sub MakeNormal(hwnd As Long)
SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
Public Sub MakeTopMost(hwnd As Long)
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Sub test()
Call MakeTopMost(Application.hwnd)
Call MakeNormal(Application.hwnd)
End Sub

有效性下拉框的高度 显示更多更直观

Option Explicit

Dim oDpd As Object
Dim sFml1
Dim prvTarget As Range

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Const dFixedPos As Double = "0.8"
Const dFixWidth As Double = "16" 'Change here to change WIDTH of the DropDown
Dim vld As Validation
Dim lDpdLine As Long

If Not prvTarget Is Nothing Then
If Not oDpd Is Nothing Then
If oDpd.Value = 0 Then
prvTarget.Value = vbNullString
Else
prvTarget.Value = Range(Mid(sFml1, 2)).Item(oDpd.Value)
End If
Set prvTarget = Nothing
End If
End If

On Error Resume Next
oDpd.Delete
sFml1 = vbNullString
Set oDpd = Nothing
On Error GoTo 0

If Target.Count > 1 Then
Set oDpd = Nothing
Exit Sub
End If

Set vld = Target.Validation
On Error GoTo Terminate
sFml1 = vld.Formula1
On Error GoTo 0

Set prvTarget = Target

lDpdLine = Range(Mid(sFml1, 2)).Rows.Count

With Target
Set oDpd = ActiveSheet.DropDowns.Add( _
.Left - dFixedPos, _
.Top - dFixedPos, _
.Width + dFixWidth + dFixedPos * 2, _
.Height + dFixedPos * 2)
End With
With oDpd
.ListFillRange = sFml1
.DropDownLines = lDpdLine
.Display3DShading = True
End With
Terminate:
End Sub

点击浏览该文件

請問如何不改變activecell之下將某一儲存格顯示於左上角?

1.

ActiveWindow.SmallScroll Up:=65536 ActiveWindow.SmallScroll ToLeft:=256 用上面的方法先回到 A1 再用下面的方法到定點 ActiveWindow.SmallScroll Down:=儲存格列號 - 1 ActiveWindow.SmallScroll ToRight:=儲存格欄號 - 1

2.

ActiveCell.Select ActiveWindow.ScrollRow = ActiveCell.Row ActiveWindow.ScrollColumn = ActiveCell.Column

3.

Application.Goto ActiveCell, True

Save Sheet as WorkBook

Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub

+++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub BreakExternalLinks()

Dim WS As Worksheet
Dim Rng1 As Range
Dim Cell As Range

For Each WS In ActiveWorkbook.Worksheets
With WS
On Error Resume Next
Set Rng1 = Cells.SpecialCells(xlCellTypeFormulas, 23)

' 23 - All formulae
' 16 - All formulae with errors
' 2 - All formulae with text
' 4 - All formulae with logic
' 6 - All formulae with text or logic

On Error GoTo 0
If Not Rng1 Is Nothing Then
For Each Cell In Rng1
If Left(Cell.Formula, 2) = "='" Then
Cell.Value = Cell.Value
End If
Next
End If
Set Rng1 = Nothing
End With
Next

End Sub

使用期限設定

' chijanzen
(原始) 2003/10/1
' 今天介紹如何讓Excel檔案有使用期限,範例中使用Windows Script"在註冊表上的讀.寫.刪除的用法
' 本範例使用期限設定 0 天,所以檔案只能開啟一次就自動銷毀
' Script 能使用的根鍵值有五個根鍵名稱
HKEY_CURRENT_USER '縮寫 HKCU
HKEY_LOCAL_MACHINE '縮寫 HKLM
HKEY_CLASSES_ROOT '縮寫 HKCR
HKEY_USERS '縮寫 HKEY_USERS
HKEY_CURRENT_CONFIG '縮寫 HKEY_CURRENT_CONFIG

Sub CheckFileDate()
Dim Counter As Long, LastOpen As String, Msg As String
If RegRead = "" Then
Term = 0 '範例用 0 天
TermDate = DateSerial(Year(Now), Month(Now), Day(Now)) + Term
MsgBox "本檔案只能使用到" & TermDate & "日" & Chr(13) & "超過期限將自動銷毀"
RegWrite (Term)
Else
If CDate(RegRead) <= Now Then
RegDelete
KillMe
End If
End If
End Sub
Sub KillMe()
Application.DisplayAlerts = False
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ThisWorkbook.Close False
End Sub


Sub RegWrite(Term)
'RegWrite:建立新鍵、將另一個值名稱加入現有鍵 (並將值指派給它)，或變更現有值名稱的值。
Dim WshShell, bKey
fname = ThisWorkbook.Name
TermDate = DateSerial(Year(Now), Month(Now), Day(Now)) + Term
Regkey = "HKCU\chijanzen\Budget\Date\" & fname
Set WshShell = CreateObject("WScript.Shell")
WshShell.RegWrite Regkey, TermDate, "REG_SZ"
End Sub


Function RegRead()
'RegRead: 從註冊傳回鍵的值或值名稱
On Error Resume Next
Dim WshShell, bKey
fname = ThisWorkbook.Name
Regkey = "HKCU\chijanzen\Budget\Date\" & fname
Set WshShell = CreateObject("WScript.Shell")
RegRead = WshShell.RegRead(Regkey)
End Function

Sub RegDelete()
'RegDelete :從註冊刪除某鍵或它的一個值(請小心使用)
Dim WshShell, bKey
Regkey = "HKCU\chijanzen\Budget\Date\"
Set WshShell = CreateObject("WScript.Shell")
WshShell.RegDelete Regkey '刪除檔名
End Sub

防止 Excel 關閉

原碼出自 Tek-Tips Forum

' Module

Option Explicit

'Set Types
Public Type LUID
LowPart As Long
HighPart As Long
End Type

Public Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type

Public Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(1) As LUID_AND_ATTRIBUTES
End Type

' Declare API functions.
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, _
ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Public Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" _
(ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Public Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, _
ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength _
As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long

' Set Set ShutDown Privilege Constants
Public Const TOKEN_ADJUST_PRIVILEGES = &H20
Public Const TOKEN_QUERY = &H8
Public Const SE_PRIVILEGE_ENABLED = &H2

Public Sub SetShutDownPrivilege()
Dim Phndl As Long, Thndl As Long
Dim MyLUID As LUID
Dim MyPriv As TOKEN_PRIVILEGES, MyNewPriv As TOKEN_PRIVILEGES

Phndl = GetCurrentProcess()
OpenProcessToken Phndl, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, Thndl
LookupPrivilegeValue "", "SeShutdownPrivilege", MyLUID
MyPriv.PrivilegeCount = 1
MyPriv.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
MyPriv.Privileges(0).pLuid = MyLUID
' Now to set shutdown privilege for my app
AdjustTokenPrivileges Thndl, False, MyPriv, 4 + (12 * MyPriv.PrivilegeCount), MyNewPriv, 4 + (12 * MyNewPriv.PrivilegeCount)

End Sub

' ThisWorkbook

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Dim Msg, Style, Title, Response
Dim MyFlag As Long, Ret As String
'Set ShutDown Constants
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4

' Define message.
Msg = "Do you want to continue ?" _
& vbCr & vbCr & "You are about to exit the excel program." _
& vbCr & vbCr & "You will need to Reboot Computer" _
& vbCr & "to restore the program!"
Style = vbYesNoCancel + vbCritical + vbDefaultButton3 ' Define buttons.
Title = "Exiting Program" ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title)
'Test the variable Response
Select Case Response
Case vbYes
'Save the file, Force Windows Closed
Me.Save
' Call Exit_Windows
Ret = InputBox("Enter Password", "Password Required")
If Ret = "testing" Then ' 更改你的密碼
Ret = InputBox("Exit Excel or Logoff User" _
& vbCr & " Enter: E or L", "What Action")
Else
MsgBox "Invalid Password", vbCritical, "Wrong Password"
Cancel = False
Exit Sub
End If
If Ret = "E" Or Ret = "e" Then
Application.Quit
Else
If Ret = "L" Or Ret = "l" Then
SetShutDownPrivilege 'Set the shutdown privilege - else reboot will fail
' Always execute a force shutdown if a shutdown is required
MyFlag = EWX_LOGOFF 'LogOff
' Grab the shutdown privilege - else reboot will fail
SetShutDownPrivilege
'Do the required action
Call ExitWindowsEx(MyFlag, 0)
End If
End If
Case vbNo
Worksheets(1).Activate
Cancel = True
Case vbCancel
Cancel = True
Case Else
'Do Nothing
End Select

End Sub

Private Sub Workbook_Open()
On Error Resume Next
'Activate the 1st worksheet using the workbooks worksheet index
Worksheets(1).Activate
'Or If you want to use the actual worksheet name
'Worksheets("Sheet1").Activate
End Sub

指定电脑上运行

'用 F8 逐句执行篮色编码，取值后更改红色部份

' ThisWorkBook

Private Declare Function w32_GetComputerName Lib "kernel32" _
Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Public LoginTime

Private Sub Workbook_Open()
Dim TempUName ' User Name
Dim TempPCName ' PC Name
TempPCName = GetComputerName
TempUName = UserName
If TempPCName <> "PCName01" And TempPCName <> "PCName02" And TempUName <> "BeeBee" _
And TempPCName <> "EMILY" Then
MsgBox "Sorry, This File is for BeeBee ONLY."
Application.Quit
End If
End Sub

Function GetComputerName()
Dim sComputerName As String
Dim lComputerNameLen As Long
Dim lResult As Long
lComputerNameLen = 256
sComputerName = Space(lComputerNameLen)
lResult = w32_GetComputerName(sComputerName, lComputerNameLen)
If lResult <> 0 Then
GetComputerName = Left(sComputerName, lComputerNameLen)
Else
GetComputerName = "Unknown"
End If
End Function

Function UserName() As String
Dim Buffer As String * 100
Dim BuffLen As Long
BuffLen = 100
GetUserName Buffer, BuffLen
UserName = Left(Buffer, BuffLen - 1)
End Function

可以监控删除行及列吗

' Module

Option Explicit

'// Worksheet RowColumn Deleted Event
'// This is NOT a real event but just hack the command button.
'// You can know when the rows or the columns was deleted by user's opelation.

Sub EventHack() ' 执行监控程序
AssignMacro "JudgeRng"
End Sub
Sub EventReset() ' 取消监控程序
AssignMacro ""
End Sub

Private Sub AssignMacro(ByVal strProc As String)
Dim lngId As Long
Dim CtrlCbc As CommandBarControl
Dim CtrlCbcRet As CommandBarControls
Dim arrIdNum As Variant

'// 293=Delete menu of the right click on row
'// 294=Delete menu of the right click on column
'// 293=Delete menu of the Edit of main menu
arrIdNum = Array(293, 294, 478)

For lngId = LBound(arrIdNum) To UBound(arrIdNum)
Set CtrlCbcRet = CommandBars.FindControls(ID:=arrIdNum(lngId))
For Each CtrlCbc In CtrlCbcRet
CtrlCbc.OnAction = strProc
Next
Set CtrlCbcRet = Nothing
Next
End Sub

Private Sub JudgeRng()
If Not TypeOf Selection Is Range Then Exit Sub
With Selection
If .Address = .EntireRow.Address Then
Call DelExecute("Row:" & .Row, xlUp)
ElseIf .Address = .EntireColumn.Address Then
Call DelExecute("Column:" & .Column, xlToLeft)
Else
Application.Dialogs(xlDialogEditDelete).Show
End If
End With
End Sub

Private Sub DelExecute(ByVal str, ByVal lngDerec As Long)
MsgBox "deleted:" & str
Selection.Delete lngDerec
End Sub

测试 WorkBook 是否已开启

Sub IsWorkBookOpen() Dim wBook As Workbook On Error Resume Next Set wBook = Workbooks("Book180.xls") If wBook Is Nothing Then MsgBox "Workbook is not open" Set wBook = Nothing On Error GoTo 0 Else MsgBox "Yes it is open" Set wBook = Nothing On Error GoTo 0 End If End Sub

请问如何不改变activecell之下将某一储存格显示于左上角
ActiveCell.Select ActiveWindow.ScrollRow = ActiveCell.Row ActiveWindow.ScrollColumn = ActiveCell.Column

或

Application.Goto ActiveCell, True

如何在 VBA 内执行 Add-in 函数

AddIns("VBA 分析工具箱").Installed = True Range("B1") = Application.Evaluate("=Weeknum(now()-7, 2)") AddIns("VBA 分析工具箱").Installed = True Workdays = Application.Evaluate("=NetWorkdays(DATE(2004,1,1) ,DATE(2004,12,31))")

或

Application.Run("ATPVBAEN.xla!Weeknum", Now(), 2)

如何禁止更改工作表名称

简单例子

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveSheet.Name <> "Sheet1" Then ActiveSheet.Name = "Sheet1" End If End Sub

详细例子 请参考【禁止更改工作表名称 Chijanzen】

检测EXCEL建立时间

Sub CreateDate() On Error Resume Next rw = 1 Worksheets(1).Activate For Each p In ActiveWorkbook.BuiltinDocumentProperties Cells(rw, 1).Value = p.Name Cells(rw, 2).Value = ActiveWorkbook.BuiltinDocumentProperties(p.Name) rw = rw + 1 Next MsgBox ActiveWorkbook.BuiltinDocumentProperties("Creation date") End Sub

Rename CodeName

点击浏览该文件

指定电脑上运行 19/F

可以监控删除行及列吗 20/F

列出所有工作薄的 VBA 21/F

vba 程式碼(代碼)是否限定容量不得超過 64K 限制嗎 23/F

找格式化的顏色 ( Font 及 Interior)

请参考 找格式化的顏色 ( Font 及 Interior)

有没有办法在EXCEL的工作表里插入一张会动的gif 动画

请参考 (向大家推荐一个可以在SHEET中使用的gif动画插件)

请参考 (不用控件也来显示GIF动画)

如何一打开工作簿,关闭所有工作表,剩 sheet1 为活动工作表

请参考
点击浏览该文件 , 用快速键 CRTL s 可转换下一页，现在只有三页(可以增加)

如何另存文件时不保存文件的宏

请参考 (在背景作業中另存新檔 chijanzen)

找寻自定范围名称左上、左下、右上及右下地址

请参考 点击浏览该文件

请教如何在单元格里获得页码和总页数

请参考 (请教如何在单元格里获得页码和总页数)

加長 驗證 的長度及寬度

请参考 加長 驗證 的長度及寬度

如何改变列表框下拉的字体格式

Excel 本身自帶的驗證下拉列表是沒有這功能，可用 Combox 方式，請參考附件

点击浏览该文件

请问全屏显示后，如何不显示“关闭全屏显示”工具栏

Sub hidebar() ' chijanzen Application.CommandBars(1).Enabled = False Application.DisplayFullScreen = True Application.CommandBars("Full Screen").Visible = False With ActiveWindow .DisplayHorizontalScrollBar = False .DisplayVerticalScrollBar = False End With End Sub Sub unhidebar() Application.CommandBars(1).Enabled = True Application.DisplayFullScreen = False With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True End With End Sub

怎样隐藏windows下面的任务栏 请参考【隐藏任务栏】

可以在不影响活页薄情况下显示时间吗

请参考【在工具列新增1个常驻的电子时钟 Chijanzen】

请参考 Ivan F Moala 点击浏览该文件

怎样判断空工作表？并自动删除

If IsEmpty(ActiveSheet.UsedRange) And ActiveSheet.Shapes.Count = 0 Then ActiveSheet.Delete