列出所有工作薄的 VBA
由 Mr Colo写的 VBA 需要在VBA内选取 Microfost Visual Basic Applications Extensbility
请在 Tools - 宏 - 安全性 - 选取 信任存取 Visual Basic 项目
不可以选择或编辑单元格
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
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
----------------- 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
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
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.
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
原碼出自 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
指定电脑上运行
'用 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
可以监控删除行及列吗
' Module
请问如何不改变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![]()
指定电脑上运行 19/F
可以监控删除行及列吗 20/F
列出所有工作薄的 VBA 21/F
vba 程式碼(代碼)是否限定容量不得超過 64K 限制嗎 23/F
找格式化的顏色 ( Font 及 Interior)
请参考 找格式化的顏色 ( Font 及 Interior)
有没有办法在EXCEL的工作表里插入一张会动的gif 动画
请参考 (向大家推荐一个可以在SHEET中使用的gif动画插件)
如何一打开工作簿,关闭所有工作表,剩 sheet1 为活动工作表
请参考
点击浏览该文件 , 用快速键 CRTL s 可转换下一页,现在只有三页(可以增加)如何另存文件时不保存文件的宏
找寻自定范围名称左上、左下、右上及右下地址
请参考
点击浏览该文件
请教如何在单元格里获得页码和总页数
加長 驗證 的長度及寬度
请参考 加長 驗證 的長度及寬度
如何改变列表框下拉的字体格式
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