VBA manual

MyFreeIT

已于 2024-12-10 18:44:57 修改

阅读量346

点赞数

CC 4.0 BY-SA版权

分类专栏： Script 文章标签： VBA Excel macos

于 2023-08-15 16:35:42 首次发布

创作源自于MyFreeIT

本文链接：https://blog.youkuaiyun.com/MyFreeIT/article/details/132301951

Script 专栏收录该内容

11 篇文章

订阅专栏

参考资料

案例1 VBA Function + Regex（RegExp）

通过写两个Function实现Excel One Column Split To Two Columns

getLineNo 获取行号

Function getLineNo(myRang As Range) As String
Dim regEx As New RegExp
Dim strPattern As String
Dim strInput As String
Dim strReplace As String
Dim strOutput As String

strPattern = "L# *\d+"
strInput = myRang.Value
strReplace = ""
With regEx
                .Global = True
                .IgnoreCase = False
                .Pattern = strPattern
End With
If regEx.test(strInput) Then
    Set theMatches = regEx.Execute(strInput)
    
    For Each Match In theMatches
         getLineNo = Match.Value
    Next 
Else
    getLineNo = ""
End If
End Function

getRemarks获取Remarks

Function getRemarks(myRang As Range) As String
Dim regEx As New RegExp
Dim strPattern As String
Dim strInput As String
Dim strReplace As String
Dim strOutput As String

strPattern = "L# *\d+"
strInput = myRang.Value
strReplace = ""
With regEx
                .Global = True
                .IgnoreCase = False
                .Pattern = strPattern
End With
getRemarks = regEx.Replace(strInput, strReplace)
End Function

实现的效果如下：
在这里插入图片描述

解决方案说明

Dim regEx As New RegExp 用到正则表达式，需要打开Regex引用。
在这里插入图片描述

Function的文件必须保存成 xlam 格式

在这里插入图片描述

Excel 加载项

通过加载项引入Function
在这里插入图片描述

案例Case2 在另一个Excel中找到最相似的Name


Function getSimilarName(myRang As Range) As String

Dim wb_src As Workbook
Dim ws_src As Worksheet
Dim row_src As Range
Dim rng_src As Range

Dim wb_this As Workbook
Dim ws_this As Worksheet

Dim regEx As New RegExp
Dim regExCn As New RegExp

Dim pattern_company_en_name As String
Dim pattern_company_cn_name As String


Set ws_this = ThisWorkbook.Sheets(1)
Set ws_src = ThisWorkbook.Sheets(2)

Set rng_src = ws_src.Range("B2:B9813")
pattern_company_en_name = "[\w\d\s.,()\’]+"
pattern_company_cn_name = "(?![\w\d\s.,()\’-]+).*$"

With regEx
                .Global = True
                .IgnoreCase = False
                .Pattern = pattern_company_en_name
End With

With regExCn
                .Global = True
                .IgnoreCase = False
                .Pattern = pattern_company_cn_name
End With

For Each row_src In rng_src.Rows
   For Each rng_src In row_src.Cells
   
        If regEx.test(myRang.Value) Then
        
                Set theMatches = regEx.Execute(myRang.Value)
                Set cnMatches = regExCn.Execute(myRang.Value)
                
                 If InStrRev(rng_src.Value, Trim(theMatches(0).Value)) <> 0 Then
                    getSimilarName = rng_src.Value
                    Exit Function
                 End If
                 
                 If InStrRev(rng_src.Value, Trim(cnMatches(0).Value)) <> 0 Then
                    getSimilarName = rng_src.Value
                    Exit Function
                 End If            
        End If    
   Next
 Next
End Function

Adobe security

disable adobe security，regedit setting

Computer\HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Adobe\Adobe Acrobat\DC\FeatureLockDown

bEnhancedSecurityStandalone

bEnhancedSecurityInBrowser
在这里插入图片描述

獲得系統位數和VBA版本號

Sub WhatVersion()
#If Win64 Then
    #If VBA6 Then
        MsgBox "64 bit and VBA v6.0 compatible"
    #ElseIf VBA7 Then
        MsgBox "64 bit and VBA v7.0 compatible"
    #ElseIf Mac Then
        MsgBox "64 bit and Mac"
    #End If
    
#ElseIf Win32 Then
    #If VBA6 Then
        MsgBox "32 bit and VBA v6.0 compatible"
    #ElseIf VBA7 Then
        MsgBox "32 bit and VBA v7.0 compatible"
    #ElseIf Mac Then
        MsgBox "32 bit and Mac"
    #End If
    
#Else
    #If VBA6 Then
        MsgBox "16 bit and VBA v6.0 compatible"
    #ElseIf VBA7 Then
        MsgBox "16 bit and VBA v7.0 compatible"
    #ElseIf Mac Then
        MsgBox "16 bit and Mac"
    #End If
#End If
End Sub

判断是否为空，两个条件Or

参考

If IsEmpty(tFrom) = True Or tFrom = “” Then

IsEmpty(tFrom) = True 如果变量没有赋值，返回True。
在这里插入图片描述

判断workbook是否存在

方法一

    Dim wb As Workbook
    For Each wb In Workbooks
        If wb.Name = "1.xlsx" Then
            MsgBox "1文件已经打开"
            Exit Sub
        End If
    Next
    MsgBox "1文件已经没有打开"

方法二

Set wb = Workbooks(WorkLocation & "\365 report.xlsm")
If Err.Number = 9 Then
Workbooks.OpenText fileName:=WorkLocation & "\365 report.xlsm", DataType:=xlDelimited, Tab:=True
End If

关闭不提示

Application.DisplayAlerts = False
操作完后打开提示
Application.DisplayAlerts = True

窗口最大化

Application.WindowState = xlMaximized

打开

Workbooks.Open ("C:"MyFolder"MyBook.xls")
or
Workbooks.OpenText fileName:=WorkLocation & "\365 report.xlsm", DataType:=xlDelimited, Tab:=True

添加新工作表

向活动工作簿添加新工作表 , 并设置该工作表的名称

Set NewSheet = Worksheets.Add
NewSheet.Name = "current Budget"

保存

ActiveWorkbook.Save
'本示例保存当前活动工作簿的副本。
ActiveWorkbook.SaveCopyAs "C:"TEMP"XXXX.XLS"

激活

Windows(Filen).Activate

Sheets(4).Activate

关闭工作簿

保存后关闭
ThisWorkbook.Saved = True
ThisWorkbook.Close

但不保存更改

 ActiveWorkbook.Close savechanges:=False

关闭除正在运行本示例的工作簿以外的其他所有工作簿，并保存其更改内容

For Each w In Workbooks
    If w.Name ThisWorkbook.Name Then
        w.Close SaveChanges:=True
    End If
Next w

方格Cell

Worksheets("Sheet1").Range("A1").Value

Sheets

For Each ws In Worksheets
    MsgBox ws.Name
Next ws

向活动工作簿添加新工作表 , 并设置该工作表的名称?
Set NewSheet = Worksheets.Add
NewSheet.Name = “current Budget”
新建工作表移到工作簿的末尾
Private Sub App_WorkbookNewSheet(ByVal Wb As Workbook, ByVal Sh As Object)
Sh.Move After:=Wb.Sheets(Wb.Sheets.Count)
End Sub

滚动鼠标

第十行移到窗口的最上面?
Worksheets("Sheet1").Activate
ActiveWindow.ScrollRow = 10

打印

Worksheets("Sheet1").PrintPreview

MsgBox

Dim ask As Integer
ask = MsgBox("Your are working in Production? 
If  you choose no,will handle test process", vbYesNo, "Choose your doing?")
If ask = VBA.vbYes Then
Production = True
Else
Production = False
End If

语法：
MsgBox(prompt[, buttons] [, title] [, helpfile, context])
prompt：对话框中的语句
buttons：选择按钮的形式。比如：确定；是、否；是否取消等等，可以根据下拉表来选。
title：弹出框的标题。

返回值：
对于函数形态的，会根据用户点选的按钮返回一个integer值，对应如下：
常数值说明
vbOK 1 确定
vbCancel 2 取消
vbAbort 3 终止
vbRetry 4 重试
vbIgnore 5 忽略
vbYes 6 是
vbNo 7 否

Print file

Workbooks.Open Filename:="E:\VTECHCMS-C.xlsx"
'Application.ActivePrinter = "KD860 on Ne04:"
ActiveWindow.SelectedSheets.PrintOut Copies:=1
    Application.DisplayAlerts = False
    ActiveWorkbook.Close
    Application.DisplayAlerts = True

或者

Workbooks.Open fileName:=WorkLocation + "\courier\ZY1-LITEON.xlsx"
'Application.ActivePrinter = "KD860 on Ne04:"
'ActiveWindow.SelectedSheets.PrintOut Copies:=1
'ActiveWindow.Close SaveChanges:=False

等待一段时间

Application.Wait (Now + TimeValue("00:00:06"))

If Else

If  Then

ElseIf

End If

打印PDF

#If VBA7 Then
Declare PtrSafe Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongPtr) As LongPtr
#Else
Declare Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongPtr) As LongPtr
#End If

Public Sub PrintFile(ByVal strPathAndFilename As String)
    Call apiShellExecute(Application.hwnd, "print", strPathAndFilename, vbNullString, vbNullString, 0)
End Sub
 
Sub test()
    PrintFile ("E:\test\mybook.pdf")
End Sub

获取路径

Application.Path 
"C:\Program Files\Microsoft Office\Root\Office16"
返回当前工作薄的路径 
ThisWorkbook.Path 
"E:\statement"
返回当前默认文件路径： 
Application.DefaultFilePath 
Application.ActiveWorkbook.Path   只返回路径 
Application.ActiveWorkbook.FullName   返回路径及工作簿文件名 
Application.ActiveWorkbook.Name   返回工作簿文件名

Copy and create a new workbook

    Sheets("Sheet1").Select
    Sheets("Sheet1").Copy
    ChDir "E:\test"
    ActiveWorkbook.SaveAs Filename:="E:\test\mybook.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False

Debug.Print()

How to Use Excel VBA Debug. Print?
在这里插入图片描述

设置Macros安全

在这里插入图片描述
或者 File /Options

如果还是Block，右键文件属性

如果Macros在服务器上，设置Macros安全

参考Microsoft
在这里插入图片描述

修复乱码

Tools / Options
在这里插入图片描述
Control Pannel / Region

打开VBA

Alt +F11

快速打开VBA

File/Options/Customize Ribbon

在这里插入图片描述

升级及兼容

在这里插入图片描述

 #If VBA7 Then
 Declare PtrSafe Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (
 ByVal hwnd As LongPtr, 
 ByVal lpOperation As String, 
 ByVal lpFile As String, 
 ByVal lpParameters As String, 
 ByVal lpDirectory As String, 
 ByVal nShowCmd As LongPtr) 
 As LongPtr
 #Else
 Declare Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
    ByVal hwnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) _
    As Long
 #End If