常用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

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

---

退出当前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)

                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

---

解决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