常用VBA代码

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。

说明

只有小写的字母会转成大写；原本大写或非字母之字符保持不变。

'将A列转字母全部转换成小写

Sub test1() '设置TEST为过程的名称

Dim x As Integer '声明X为整数变量

For x = 1 To 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

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))

退出当前excel进程

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)

Else

For iStep = LBound(iArg) To UBound(iArg)

tempStr = tempStr & CStr(iArg(iStep))

End If

Else

tempStr = tempStr & CStr(iArg)

End If

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

解决VBA运行因公式造成缓慢的问题

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