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