VBA代码（珍藏）
'**关闭屏幕刷新
Application.ScreenUpdating = False
'**取消删除工作表警告提示
Application.DisplayAlerts = False
'**引用打开窗口
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Set fd = Application.FileDialog(msoFileDialogOpen)
fd.InitialFileName = Sheets("设置").Range("CU7").Value & "\库存核对" '默认打开的文件夹
With fd
.AllowMultiSelect = True '可选多个文件
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
FJ = Split(vrtSelectedItem, "\")
ThisWorkbook.Sheets("设置").Range(CR).Value = FJ(3) '记录文件名
ThisWorkbook.Sheets("设置").Range("AG1").Value = FJ(3) '记录文件名
fd.Execute '执行打开
Me.CommandButton62.Enabled = True
Exit For
Next
End If
End With
Set fd = Nothing
****得到计算机名称
Environ("Computername")
****判断是不是数字
If IsNumeric(InputBox("Please Input:")) Then
****筛选非空单元格
ActiveSheet.Range("$E$7:$I$15").AutoFilter Field:=1, Criteria1:="<>"
****仅贴值
Range("F5:J25").Select
Selection.Copy
Range("E5").Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
IconFileName:=False
****设置是否冻结空格
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
****设置页面
With ActiveSheet.PageSetup
.LeftFooter = "编制： 审核：" '页脚LEFT
.PrintTitleRows = "$1:$3" '要打印的默认页头
.PrintArea = "$A$1:$E$12" '打印区域
End With
.PrintOut Copies:=2 '打印(2份)
****设置批注
Range("F8").AddComment'添加批注
Range("F8").Comment.Visible = False'隐藏框
.Comment.Shape.TextFrame.AutoSize = True'自动调整框大小
.Comment.Font.FontStyle = "常规" '将字体设置为“常规”（不加粗）(不成功)
'-------------------------------------
Range("F8").Comment.Text Text:="黄传兵:" & Chr(10) & "SS"
If Range("F8").Comment Is Nothing Then '如果没有批注内容
Public Function OPEN_JL(WJ As String) '检测是否有相应引用文件的打开记录
Dim I As Integer
Dim MC, MC_CR As String
L3 = ThisWorkbook.Sheets("设置").Range("N2").Value
For I = 4 To L3 + 3
MC_CR = "N" & I
MC = ThisWorkbook.Sheets("设置").Range(MC_CR).Value
If UCase(MC) = UCase(WJ) Then
OPEN_JL = "Y"
Exit For
End If
Next I
End Function
'打开需引用的文件
Public Sub OPEN_WJ(LJ, WJ As String)On Error GoTo X:
Dim M4, Y3 As String
Dim LJWJ As String
LJWJ = LJ & WJ
If OPEN_YN(WJ) <> "Y" Then '如果未被其它引用并打开
Workbooks.Open Filename:=LJWJ
L3 = ThisWorkbook.Sheets("设置").Range("N2").Value
M3_CR = "N" & L3 + 4
M4_CR = "O" & L3 + 4
ThisWorkbook.Sheets("设置").Range(M3_CR).Value = WJ
ThisWorkbook.Sheets("设置").Range(M4_CR).Value = 1
Windows(WJ).Visible = False
Else '如果已被其它引用并打开
If OPEN_JL(WJ) = "" Then
L3 = ThisWorkbook.Sheets("设置").Range("N2").Value
M3_CR = "N" & L3 + 4
M4_CR = "O" & L3 + 4
ThisWorkbook.Sheets("设置").Range(M3_CR).Value = WJ
ThisWorkbook.Sheets("设置").Range(M4_CR).Value = 2
End If
End If
Exit Sub
X:
MsgBox """ & WJ & ""未打开，请检查路径。"
End Sub
'检测文件是否已经打开
Public Function OPEN_YN(WJ As String) Dim X As Workbook
For Each X In Application.Workbooks
If UCase(CStr(X.Name)) = UCase(WJ) Then
OPEN_YN = "Y"
Exit For
End If
Next
End Function
'关闭引用文件
Public Sub CLOSE_YY() On Error Resume Next
Dim I, L As Integer
Dim MC, MC_CR, ZT, ZT_CR As String
L = ThisWorkbook.Sheets("设置").Range("N2").Value
For I = L + 3 To 4 Step -1
MC_CR = "O" & I
ZT_CR = "P" & I
MC = ThisWorkbook.Sheets("设置").Range(MC_CR).Value
ZT = ThisWorkbook.Sheets("设置").Range(ZT_CR).Value
If MC <> "" Then
If Workbooks(MC).Saved = False Then Workbooks(MC).Save
If ZT = 1 Then Workbooks(MC).Close '如果是本文件引用并打开的则关闭
ThisWorkbook.Sheets("设置").Range(MC_CR).Value = ""
ThisWorkbook.Sheets("设置").Range(ZT_CR).Value = ""
End If
Next I
End Sub
***设置控件变量
Dim LB As MSForms.Label
Set LB = SYS.Controls("LB" & I + 1)
***只读方式打开、关闭时不保存
, ReadOnly:=True
, SaveChanges:=False
文本框输入限制处理-
TextBox1.MaxLength = 5 '最大允许输入的字符长度5
TextBox1.AutoTab = True '当达到最大允许输入的字符长度是，自动跳格
***得到文件扩展名
Right(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) _
- InStr(ActiveWorkbook.Name, ".") + 1)
***得到指定字符出现的位置,并替换字串中指定的字符
Z = Me.TextBox37.Value
LS = InStr(1, Z, "(")
RS = InStr(1, Z, ")")
Replace(Z, Mid(Z, LS + 1, RS - LS - 1), Sheets("设置").Range("J1").Value)
***单元格背景、前景设置
.Cells(R + 1, C).Interior.Color = 255'背景红
.Cells(R + 1, C).Font.ThemeColor = xlThemeColorDark1 '前景白
.Cells(R + 1, C).Interior.Pattern = xlNone'背景无
.Cells(R + 1, C).Font.ColorIndex = xlAutomatic'前景黑（默认）
***当前单元格的行、列号
Selection.Row
Selection.Column
***当关闭文件时自动备份----------------------------------
Dim NEW_NAME As String
NEW_NAME = Year(Date) & Month(Date)
NEW_NAME = "\\Ck2\公司平台 (e)\仓库备份勿删\月度进销存" & NEW_NAME & ".xlsm"
Me.SaveAs Filename:=NEW_NAME, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
***处理单元格批注
'U_NAME是修改人的名字
WITH RANGE(CR)
If .Comment Is Nothing Then
.AddComment
.Comment.Visible = False
.Comment.Text Text:=U_NAME & ":" & Chr(10) & "原" & Z & "，" & Date & GG
Else
.Comment.Text Text:=.Comment.Text & Chr(10) & U_NAME & ":" & Chr(10) & "原" & Z & "，" & Date & GG
End If
END WITH
Public Function HOW_CS(STR1 As String, STR2 As String) '得到 STR2 在 STR1 中出现的次数
Dim I As Integer
Dim B As String
'黄传兵定稿的2008-12-17
B = STR1
If InStr(B, STR2) = 0 Then
I = 0
Else
For I = 1 To 50
B = Replace(B, Left(B, InStr(B, STR2)), "", 1, 1)
If Len(B) = 0 Or InStr(B, STR2) = 0 Then
Exit For
End If
Next I
End If
HOW_CS = I
End Function
用API切换打印机
Application.Dialogs(xlDialogPrinterSetup).Show
Application.ActivePrinter'当前打印机
'隐藏列
Columns(I + J).EntireColumn.Hidden = True '隐藏列
'隐藏行
Rows(I).EntireRow.Hidden =True
'隐藏表
Sheets("表1").Visible = False
'为Image控件添加图片
Me.Image1.Picture = LoadPicture("E:\跟踪卡管理系统\跟踪卡日志\CT1.jpg")
Sub OUT_JPG() '将图表另存为JPG
Dim shap As Shape
Dim i As Integer
With ThisWorkbook.Sheets("1")
For i = 1 To .Shapes.Count
Set shap = .Shapes(i)
shap.Copy
With .ChartObjects.Add(0, 0, shap.Width, shap.Height).Chart
.Paste
.Export "d:\" & i & ".jpg"
.Parent.Delete
End With
Next i
End With
End Sub
'动态添加控件
Set Mycmd = Controls.Add("MsForms.CommandButton.1") ', CommandButton2，Visible)
Mycmd.Left = 18
Mycmd.Top = 150
Mycmd.Width = 175
Mycmd.Height = 20
Mycmd.Caption = "非常有趣。" & Mycmd.Name
'数字转换为中文大写（A1单元格）公式
=IF(A1<0,"(金额为负无效)",IF((A1-INT(A1))=0,"(人民币)"&TEXT(A1,"[DBNUM2]")&"元整",IF(INT(A1*10)-A1*10=0,"(人民币)"&TEXT(INT(A1),"[DBNUM2]")&"元"&TEXT((INT(A1*10)-INT(A1)*10),"[DBNUM2]")&"角整",TEXT(INT(A1),"[DBNUM2]")&"元"&IF(INT(A1*10)-INT(A1)*10=0,"零",TEXT(INT(A1*10)-INT(A1)*10,"[DBNUM2]")&"角")&TEXT(RIGHT(A1,1),"[DBNUM2]")&"分")))
UCase 函数
返回 Variant (String)，其中包含转成大写的字符串。
语法
UCase(string)
必要的 string 参数为任何有效的字符串表达式。如果 string 包含 Null，将返回 Null。
说明
只有小写的字母会转成大写；原本大写或非字母之字符保持不变。
小写
Sub test1() '设置TEST为过程的名称
Dim x As Integer '声明X为整数变量
Range("A65536").End(xlUp).Row '设置X的范围为1到A列最后空白单元格的行数
Range("A" & x) = LCase(Range("A" & x)) '附值单元格Ax的格式全部转换为小写,如果是UCase,则转换成大写
Next x '循环X
End Sub '结束过程
'复制单元格并改名
Sheets("Sheet1").Copy Before:=/After:=Sheets(2)
Sheets("Sheet1 (4)").Name = "1"
Public Sub QHHZ(TXT As MSForms.TextBox, GJZ, DTHZ As String)
'将指定文本框中指定的文字块（可多选，用“,”分隔）替换为特定的文字(文本框名，要替换的字，被替换的字)
Dim I As Integer
Dim Y As String
Dim FJ() As String
With TXT
If .Value <> "" Then
FJ = Split(DTHZ, ",")
Y = ""
For I = 0 To 3
If InStr(1, .Value, FJ(I)) <> 0 Then '如果找到FJ(I)最先出现的位置
Y = "Y"
Exit For
End If
Next I
If Y = "Y" Then
.Value = Replace(.Value, FJ(I), GJZ)
Else
.Value = .Value & GJZ
End If
End If
.SetFocus
End With
End Sub
Function SheetIsExist(strExcleName As String, strSheetName As String) As Boolean
'//判断名称的工作表是否已经在指定的Excel文件中存在
Dim shtSheet As Worksheet
SheetIsExist = False
On Error GoTo lab1
Set shtSheet = Workbooks(strExcleName).Sheets(strSheetName)
If shtSheet Is Nothing Then
SheetIsExist = False
Else
SheetIsExist = True
End If
Set shtSheet = Nothing'释放变量空间
Exit Function
lab1:
SheetIsExist = False
End Function
Replace(expression, find, replace[, start[, count[, compare]]])
函数功能：返回一个字符串，该字符串中指定的子字符串已被替换成另一子字符串，并且替换发生的次数也是指定的。
说明：
expression 必需的。字符串表达式，包含要替换的子字符串。
find 必需的。要搜索到的子字符串。
replace 必需的。用来替换的子字符串。
start 可选的。在表达式中子字符串搜索的开始位置。如果忽略，假定从1开始（若不是从1开始，则之前的字符将不返回***，可用Left()解决）。
count 可选的。子字符串进行替换的次数。如果忽略，缺省值是 –1，它表明进行所有可能的替换。
compare 可选的。数字值，表示判别子字符串时所用的比较方式。关于其值，请参阅“设置值”部分。
隐藏或显示列
ActiveSheet.Columns("AW:BE").EntireColumn.Hidden = False
切换控制权给系统，用于显示进度条（放置于显示进度条的代码之后）
DoEvents
'为单元格中指定的文字添加“下划线”
With .Cells(I, J).Characters(Start:=7, Length:=3).Font
.Underline = xlUnderlineStyleSingle
End With
'判断数据类型
TypeName(i)="Single" 就是单精度浮点数
TypeName(i)="Double" 就是双精度浮点数
TypeName(i)="String" 就是字符串
on error 语句的具体用法
①on error resume next 表示忽略所有错误继续执行下一语句，如果还有错就再往下
②on error goto 0 表示出现错误时不进行转向，直接中断执行
③on error goto <标号> 表示出现错误时转到标号处执行
'判断是否存在指定工作表
Dim wsh As Worksheet
For Each wsh In Worksheets
If InStr(wsh.Name, "省") Then
Call SUB1
Else
Call SUB2
End If
Next
Private Sub TextZ_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'如果离开TextZ，按"回车"则转移焦点到TextX
If KeyCode = 13 Then
With Me.TextX
.SetFocus
If .Value <> "" Then
.SelStart = 0
.SelLength = Len(.Value)
End If
End With
End If
End Sub
Private Sub ListXYZ_Click()
'将列表框中的数据分别显示到文本框中
With Me
If .ListXYZ.ListIndex <> -1 Then
.LabelId = .ListXYZ.Column(0, .ListXYZ.ListIndex)
.TextX = .ListXYZ.Column(1, .ListXYZ.ListIndex)
.TextY = .ListXYZ.Column(2, .ListXYZ.ListIndex)
.TextZ = .ListXYZ.Column(3, .ListXYZ.ListIndex)
End If
End With
End Sub
MsgBox ThisWorkbook.Sheets("A7").Range("B50").End(xlUp).Row
MsgBox ThisWorkbook.Sheets("A7").Range("zz2").End(xlUp).Column
获得第4行最后有数据的“列号“ 的公式
=LOOKUP(1,0/(4:4<>""),COLUMN(4:4))
获得H列最后有数据的“行号“ 的公式
=LOOKUP(1,0/(H:H<>""),ROW(H:H))
Application.Quit |
定义函数的可选参数： Optional cf = False
例子：
Public Function find_list_easy(wkbook, wksheet, maxRange As String, startColorRow, zColorRow As Integer, _
xy As String, Optional cf = False) As String
若想在只读文件关闭时不保存且不提示，可如下：
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Me.Saved = False And Not Me.ReadOnly Then
Me.Save
Else
Me.Saved = True
End If
End Sub
可以用ParamArray来传递不定参数，示例代码如下：
Function MYCONCATE(ParamArray Args() As Variant) As String
Dim iArg As Variant
Dim tempStr As String
Dim iStep As Integer
For Each iArg In Args
If IsArray(iArg) Then
If IsObject(iArg) Then
For Each icell In iArg
tempStr = tempStr & CStr(icell.Text)
Next
Else
For iStep = LBound(iArg) To UBound(iArg)
tempStr = tempStr & CStr(iArg(iStep))
Next
End If
Else
tempStr = tempStr & CStr(iArg)
End If
Next
MYCONCATE = tempStr
End Function
获取当前单元格的值……
ActiveCell.Value，这个我忘了，汗1个
MsgBox ActiveCell.EntireColumn.Column '第几列
MsgBox ActiveCell.EntireRow.Row '第几行
将某列设置为“文本”或“通用”格式
Columns("C:C").Select
Selection.NumberFormatLocal = "@"
Selection.NumberFormatLocal = "G/通用格式"
'若表中存在“筛选”，取消之
ActiveSheet.ShowAllData
'“关闭”文件前自动判断是否为“只读方式”打开，若是则不提示保存，否则自动保存并关闭，适用于文件BeforeClose事件中
With Me
If .ReadOnly = True Then
.Saved = True
Else
If .Saved = False Then
.Save
.Close
End If
End If
End With
Application.Calculation = xlManual'关闭自动计算公式功能（放在程序开关）
Application.Calculation = xlAutomatic'打开自动计算公式功能（放在程序结尾）
time1 = Time '记录开始时间
time2 = Time '记录结束时间
Me.Label6.Caption = "用时：" & Round((time2 - time1) * 24 * 3600, 1) & " 秒" '显示用时
‘设置整个单元格的“前景、背景色”
If Me.CheckBox1.Value = False Then
Cells.Interior.Color = Sheets("设置").Range("G1").Interior.Color'背景色
Cells.Font.Color = Sheets("设置").Range("G1").Font.Color'前景色
End If
受“筛选”影响结果的统计公式：
=SUBTOTAL(9,F7:F1000)
'关闭设置
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False '注:这是工作表级的设置
'打开（改变的）设置
Application.ScreenUpdating = True 'screenUpdateState
Application.DisplayStatusBar = True 'statusBarState
Application.Calculation = xlAutomatic 'calcState
Application.EnableEvents = True 'eventsState
ActiveSheet.DisplayPageBreaks = True 'displayPageBreaksState '注:这是工作表级的设置
'设置在边距
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.36)
.RightMargin = Application.InchesToPoints()
.TopMargin = Application.InchesToPoints()
.BottomMargin = Application.InchesToPoints()
End With
'获取鼠标坐标点：
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Type POINTAPI
X As Long
Y As Long
End Type
Public Function getmouse_x_y() As POINTAPI
GetCursorPos getmouse_x_y
End Function
sub test()
'call getmouse_x_y '调用“获取鼠标坐标值过程”（假定你们给的过程/程序，名叫getmouse_x_y）
if getmouse_x_y.x>100 and getmouse_x_y.y>100 then …… '根据返回当前鼠标的坐标值执行某过程/程序
……
end sub'为获取鼠标位置，引入API(写在模块开始处)
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'为获取鼠标位置，声明POINTAPI数据结构
Type POINTAPI
X As Long
Y As Long
End Type
'-------------------------------------------------------
Public Function get_point() As POINTAPI
'获取鼠标位置
GetCursorPos get_point
'MsgBox get_point.X & "," & get_point.Y
End Function
UBound(array)
'判断窗体是否打开（仅非模式有效）
If form1.Visible = True then
