VBA编程常见场景的二十八种常用方法

imitker 编程

很多时候很多人觉得编程很难。

甚至连很多程序员都觉得是这样。

也有这样一种说法：高级或者资深的编程者并不在乎用的什么编程语言，并且可以在很短的时间内掌握一门编程语言。

为什么会有如此大的反差呢？

其实透过本质来分析就容易多了。其实无论是什么编程语言，所面临的解决实际问题的场景都是很接近的。

无非就是增、删、改、查，读、写、比、对以及加上逻辑判断条件和遍历，仅此而已。

打开一个或多个文件

Dim importFile(), importFileName As String
'打开文件
importFile = Application.GetOpenFilename("Excel文件,*.xlsx", , , , True)
'If importFile = "False" Then Exit Sub
For i = 1 To UBound(importFile)
    Set wk = GetObject(importFile(i))
    For j = Len(importFile(i)) To 1 Step -1
        If InStr("\", Mid$(importFile(i), j, 1)) Then Exit For
    Next
    importFileName = Mid$(importFile(i), j + 1, Len(importFile(i)) - j)
    Set thisSheet = Workbooks(importFileName).Sheets(1)
    '处理逻辑代码
Next i

文件下载

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long _
        ) As Long
#Else
    Private Declare  Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long _
        ) As Long
#End If
Public Function downoadTolocal(ByVal Down_link As String, ByVal FileName As String)
    If downloadFile(Down_link, FileName) = True Then
        'MsgBox "Download Successfully"
    Else
        MsgBox "File Download Failed"
    End If
End Function
Public Function downloadFile(ByVal strURL As String, ByVal strFile As String) As Boolean
    Application.EnableCancelKey = xlDisabled
    Dim lngReturn&
    '用lngReturn接收返回的结果
    lngReturn = URLDownloadToFile(0, strURL, strFile, 0, 0)
    ' 注意：URLDownloadToFile函数返回0表示文件下载成功
    '判断返回的结果是否为0,则返回True，否则返回False
    If lngReturn = 0 Then
        downloadFile = True
    Else
        downloadFile = False
    End If
End Function

获取本机ip地址

Function GetlocalhostIP()
    Dim WMI, objs
    Set WMI = GetObject("WinMgmts:")
    Set objs = WMI.ExecQuery("Select * from Win32_NetworkAdapterConfiguration")
    For Each objNetAdapter In objs
        If TypeName(objNetAdapter.IPAddress) <> "Null" Then
            GetlocalhostIP = objNetAdapter.IPAddress(0)
            Exit Function
        End If
    Next
End Function

读取文件内容

Function ReadFileArray(FilePath As String)
    Dim HolidayData As String '定义读取用变量
    Dim temp As String '临时存放读取的数据
    Dim Myfile As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Myfile = Dir(FilePath, vbReadOnly + vbHidden + vbArchive)
    If Myfile = "" Then
        fs.CreateTextFile FilePath
    End If
    Open FilePath For Input As #1 '打开文件，读取本地文件
    'Line Input #1, HolidayData '先读第1行到变量
    Do While Not EOF(1) '循环到文件尾
        Line Input #1, temp '读1行
        keywordsInfo = Split(temp, Chr(11))
        AllkeywordsInfo = keywordsInfo(9) & "|" & temp '读取到的数据用"|"分割
    Loop
    Close #1 '关闭文件
    '分割后的结果作为数组返回到主函数
    ReadFileArray = Split(HolidayData, "|")
End Function

自制进度条

Sub ShowPercent()
    Dim i, j As Integer, k As String, arr As Variant
    arr = Array(">", ">>", ">>>", ">>>>", ">>>>>", ">>>>>>", ">>>>>>>", ">>>>>>>>", ">>>>>>>>>", ">>>>>>>>>>>>>>>>>>")
    k = "分析处理中,请稍候"   '提示的文字信息
    j = 0
    Form_wait.Show 0  '显示进度窗口
    For i = 1 To 100 Step 0.1   '进度条行进速度
        If j > UBound(arr) Then j = 0
        Form_wait.Label4.Caption = k & arr(j)   '进度条样式
        j = j + 1
        Form_wait.Label2.Width = i / 100 * 200
        Form_wait.Label3.Caption = Format(i, "0") & "%"
        DoEvents   '转让控制权
    Next i
    Unload Form_wait
End Sub

向工作表输出代码

Function CRColorSet(ByVal TargetBook As Workbook, sheetName As String, CEnd As String)
    '工具---引用勾选  Microsoft Visual Basic For Applications Extensibility 5.3
    '信任中心需要勾选“信任对VBA工程对象模型的访问”
    With TargetBook.VBProject.VBComponents(sheetName).CodeModule
        If Not .Find("Worksheet_SelectionChange", 1, 1, -1, -1) Then  '避免重复写入产生二义性
            .InsertLines 1, "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
            .InsertLines 2, "    On Error Resume Next"
            .InsertLines 3, "    Application.ScreenUpdating = False"
            .InsertLines 4, "    Cells.Interior.ColorIndex = -4142"
            .InsertLines 5, "    Rows(Target.Row).Interior.ColorIndex = 17"
            .InsertLines 6, "    Columns(Target.Column).Interior.ColorIndex = 17"
            .InsertLines 7, "   Range(" & Chr(34) & "A1:" & CEnd & "1" & Chr(34) & ").Interior.ColorIndex = 43"  '首行颜色受影响
            .InsertLines 8, "   Application.ScreenUpdating = True"
            .InsertLines 9, " End Sub"
        End If
    End With
End Function

将信任源写入注册表

Sub RegWrite()
    Dim WShell As Object
    Set WShell = CreateObject("Wscript.Shell")
    WShell.RegWrite "HKCU\Software\Microsoft\Office\Common\Security\UFIControls", 1, "REG_DWORD"
    WShell.RegWrite "HKCU\Software\Microsoft\VBA\Security\LoadControlsInForms", 1, "REG_DWORD"
    Set WShell = Nothing
End Sub

年/月/日三级联动

Function showForm(Form_user As Variant)
    Call common_dim
    Form_user.ComboBox1.List = DATEYYYY
    Form_user.ComboBox6.List = DATEYYYY
    Form_user.ComboBox1.Text = Format(Date - 1, "YYYY")
    Form_user.ComboBox6.Text = Format(Date - 1, "YYYY")
    Form_user.ComboBox2.List = DATEMM
    Form_user.ComboBox5.List = DATEMM
    Select Case Form_user.ComboBox2.Text
    Case "02"
        If CInt(Form_user.ComboBox1.Text) Mod 4 = 0 And CInt(Form_user.ComboBox1.Text) Mod 100 <> 0 Then
            Form_user.ComboBox3.List = DATEDD_29
        Else
            Form_user.ComboBox3.List = DATEDD_28
        End If
    Case "01", "03", "05", "07", "08", "10", "12"
        Form_user.ComboBox3.List = DATEDD_31
    Case "04", "06", "09", "11"
        Form_user.ComboBox3.List = DATEDD_30
    End Select
    Select Case Form_user.ComboBox5.Text
    Case "02"
        If CInt(Form_user.ComboBox6.Text) Mod 4 = 0 And CInt(Form_user.ComboBox6.Text) Mod 100 <> 0 Then
            Form_user.ComboBox4.List = DATEDD_29
        Else
            Form_user.ComboBox4.List = DATEDD_28
        End If
    Case "01", "03", "05", "07", "08", "10", "12"
        Form_user.ComboBox4.List = DATEDD_31
    Case "04", "06", "09", "11"
        Form_user.ComboBox4.List = DATEDD_30
    End Select
    Form_user.ComboBox2.Text = Format(Date - 1, "MM")
    Form_user.ComboBox3.Text = "01"
    Form_user.ComboBox5.Text = Format(Date - 1, "MM")
    Form_user.ComboBox4.Text = Format(Date - 1, "DD")
    Form_user.Show
End Function

解压zip文件

Sub UnzipFile()
    Dim FSO As Object
    Dim oApp As Object
    Dim strFileName As Variant
    Dim strFileNameFolder As Variant
    Dim strDefPath As String
    Dim strDate As String
    '只支持Zip压缩文件，不支持Rar或其它压缩格式
    strFileName = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=False)
    If Not (strFileName = False) Then
        '新文件夹的上级文件夹.
        '你也可以支持指定路径 strDefPath = "C:\Users\test"
        strDefPath = Application.DefaultFilePath
        If Right(strDefPath, 1) <> "" Then
            strDefPath = strDefPath & ""
        End If
        '创建文件夹名称
        strDate = Format(Now, " dd-mm-yy h-mm-ss")
        strFileNameFolder = strDefPath & "\MyUnzipFolder " & strDate & ""
        '创建名为 strDefPath 的普通文件夹
        MkDir strFileNameFolder
        '提取所有文件到此创建的文件夹
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(strFileNameFolder).CopyHere oApp.Namespace(strFileName).items
        '假如你只需要提取某一个文件，可以如下:
        'oApp.Namespace(strFileNameFolder).CopyHere oApp.Namespace(strFileName).items.Item("20201216_162528.csv")
        MsgBox "文件已经解压到: " & strFileNameFolder
        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        '删除临时文件
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    End If
    
End Sub

远程下载压缩包文件并解压

Public Const OFFSET As Long = &H8
#If VBA7 Then
    Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
    Public Declare PtrSafe Function InitDecompression Lib "gzip.dll" () As Long
    Public Declare PtrSafe Function CreateDecompression Lib "gzip.dll" (ByRef context As Long, ByVal Flags As Long) As Long
    Public Declare PtrSafe Function DestroyDecompression Lib "gzip.dll" (ByRef context As Long) As Long
    Public Declare PtrSafe Function Decompress Lib "gzip.dll" (ByVal context As Long, inBytes As Any, ByVal input_size As Long, outBytes As Any, ByVal output_size As Long, ByRef input_used As Long, ByRef output_used As Long) As Long
    Public Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
#Else
    Public Declare  Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
    Public Declare  Function InitDecompression Lib "gzip.dll" () As Long
    Public Declare  Function CreateDecompression Lib "gzip.dll" (ByRef context As Long, ByVal Flags As Long) As Long
    Public Declare  Function DestroyDecompression Lib "gzip.dll" (ByRef context As Long) As Long
    Public Declare  Function Decompress Lib "gzip.dll" (ByVal context As Long, inBytes As Any, ByVal input_size As Long, outBytes As Any, ByVal output_size As Long, ByRef input_used As Long, ByRef output_used As Long) As Long
    Public Declare  Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
#End If
Const cp_UTF8 = 65001
Const cp_GB2312 = 936
Const cp_GB18030 = 54936
Const cp_UTF7 = 65000
Public Function getGzipDirect(downloadUrl As String)
    Dim brr() As Byte
    Dim a As String
    ReDim brr(0)
    'sogouSentUrlv2 = "http://api.agent.sogou.com:80/DownloadReport.report?accountId=20285450&fid=panama_default_class_c69d702a-0c66-4026-b751-66bffd7d97c7_cedc73057e7b3aa50098df97bed6cad0"
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", downloadUrl, False
        .Send
        brr = .responseBody
    End With
    CopyMemory brr(0), brr(i), UBound(brr)
    ReDim Preserve brr(UBound(brr) - 8)
    UnCompressByte brr
    a = Utf8ToUnicode(brr)
    unzipArr = Split(a, Chr(10))
    getGzipDirect = Split(unzipArr(1), ",")
End Function
Public Function Utf8ToUnicode(ByRef Utf() As Byte) As String
    Dim lRet As Long
    Dim lLength As Long
    Dim lBufferSize As Long
    lLength = UBound(Utf) - LBound(Utf) + 1
    If lLength <= 0 Then Exit Function
    lBufferSize = lLength * 2
    Utf8ToUnicode = String$(lBufferSize, Chr(0))
    lRet = MultiByteToWideChar(cp_GB2312, 0, VarPtr(Utf(0)), lLength, StrPtr(Utf8ToUnicode), lBufferSize)    '注意哦，这里是“cp_GB2312 = 936”
    If lRet <> 0 Then
        Utf8ToUnicode = Left(Utf8ToUnicode, lRet)
    Else
        Utf8ToUnicode = ""
    End If
End Function
'更新  20181219 注释DestroyDecompression，解决excel假死问题
Public Function UnCompressByte(ByteArray() As Byte) As Boolean
    Dim BufferSize As Long
    Dim Buffer() As Byte
    Dim lReturn As Long
    Dim outUsed As Long
    Dim inUsed As Long
    CopyMemory BufferSize, ByteArray(0), OFFSET
    BufferSize = BufferSize + (BufferSize * 0.01) + 12
    ReDim Buffer(BufferSize) As Byte
    Dim contextHandle As Long: InitDecompression
    CreateDecompression contextHandle, 1
    lReturn = Decompress(ByVal contextHandle, ByteArray(0), UBound(ByteArray) + 1, Buffer(0), BufferSize, inUsed, outUsed)
    'DestroyDecompression contextHandle
    ReDim Preserve ByteArray(0 To outUsed - 1)
    CopyMemory ByteArray(0), Buffer(0), outUsed
End Function

获取计算机名和登录用户名

'获取计算机名
computerName = Environ("computername")
'获取登录用户名
userName = Environ("username")

通用数据库操作方法（含查询、更新）

Function DBLinkSql(strSQL As String, myCells As String, flag As Integer)
    '定义mysql数据源（需要先在本地安装驱动及创建好数据源）
    Dim oConn As New ADODB.Connection
    '连接mysql数据库
    oConn.ConnectionString = "Driver={MySQL ODBC 8.0 Unicode Driver};Server=ip;PORT=3306;DB=dbName;UID=username;PWD=password;OPTION=3;"
    '和数据库建立连接
    oConn.Open
    '判断是否能够正常连接数据库
    If oConn.State <> 1 Then
        Set oConn = Nothing
        MsgBox "数据库联接失败！"
        Exit Function
    Else
        '定义数据源执行结果对象
        Dim rstMain  As ADODB.Recordset, rstMain_1 As ADODB.Recordset
        Set rstMain = New ADODB.Recordset
        Set rstMain_1 = New ADODB.Recordset
        'Cells(50, 1).Value = strSQL
        If flag = 1 Then '单纯查询
            rstMain.CursorLocation = 3 '该属性可返回记录数
            rstMain.Open strSQL, oConn, 3, 3
            If rstMain.EOF Then
                'MsgBox "没有查询到任何数据！"
                Exit Function
            Else
                DBLinkSql = CLng(rstMain.RecordCount) '记录数
                If myCells <> "" Then
                    Range(myCells).CopyFromRecordset rstMain '结果集输出到excel
                End If
                rstMain_1.Open strSQL, oConn, 3, 3
                sqlResult = rstMain_1.GetRows  '返回结果集
            End If
            rstMain.Close: Set rstMain = Nothing
            rstMain_1.Close: Set rstMain_1 = Nothing
        ElseIf flag = 2 Then  '修改/删除/插入数据
            Set rstMain = oConn.Execute(strSQL) '执行sql语句更新数据
        End If
    End If
    '关闭连接
    oConn.Close: Set oConn = Nothing
End Function

目标工作表存在则先删除再创建，不存在直接创建

'判断是否存在打开的工作簿，0表示不存在
If Workbooks.Count = 0 Then
    '新建一个工作簿，并添加表头
    Workbooks.Add
    ActiveSheet.Name = "xxx"
    '当前存在打开的工作簿
Else
    Dim scount As Integer
    scount = ActiveWorkbook.Sheets.Count
    If scount = 1 And InStr(Sheets(1).Name, "xxx") = "1" Then
        ActiveWorkbook.Sheets.Add
    End If
    Application.DisplayAlerts = False '强制删除
    For i = 1 To ActiveWorkbook.Sheets.Count
        If Sheets(i).Name = "xxx" Then
            Sheets(i).Delete
            Exit For
        End If
    Next i
    ActiveWorkbook.Sheets.Add
    ActiveWorkbook.ActiveSheet.Name = "xxx"
End If

隐藏网格线/列宽自动调整/格式化输出方法

ActiveWindow.DisplayGridlines = False
Columns("D:F").EntireColumn.AutoFit
Columns("H:l").ColumnWidth = 17
Range("BB4:BK4").NumberFormatLocal = "0%"
Range("BB4:BK4").NumberFormatLocal = "0.00"

内容相同的相邻行着相同颜色，否则着不同颜色

 For i = 2 To ActiveSheet.UsedRange.Rows.Count
     
     If Cells(i, 3).Value = Cells(i - 1, 3).Value Then
         Range("A" & i & ":D" & i).Select
         With Selection.Interior
             .Pattern = xlSolid
             .PatternColorIndex = xlAutomatic
             .ThemeColor = xlThemeColorAccent1
             .ThemeColor = Range("C" & i - 1).Interior.ThemeColor
             .TintAndShade = 0.799981688894314
             .PatternTintAndShade = 0
         End With
     Else
         If Range("C" & i - 1).Interior.ThemeColor = xlThemeColorAccent1 Then
             Range("A" & i & ":D" & i).Select
             With Selection.Interior
                 .Pattern = xlSolid
                 .PatternColorIndex = xlAutomatic
                 .ThemeColor = xlThemeColorAccent2
                 .TintAndShade = 0.799981688894314
                 .PatternTintAndShade = 0
             End With
         Else
             Range("A" & i & ":D" & i).Select
             With Selection.Interior
                 .Pattern = xlSolid
                 .PatternColorIndex = xlAutomatic
                 .ThemeColor = xlThemeColorAccent1
                 .TintAndShade = 0.799981688894314
                 .PatternTintAndShade = 0
             End With
         End If
         
     End If
 Next i

带引号（"）、连接符（&）的复杂公式输出方法

Range("D4").Value = "=iferror(REPT(" & Chr(34) & "|" & Chr(34) & ",B4/" & dataRate & ")" & Chr(38) & "Round(B4*100/B5,2)" & Chr(38) & Chr(34) & "%和" & Chr(34) & Chr(38) & "Round(B4*100/B6,2)" & Chr(38) & Chr(34) & "%" & Chr(34) & "," & Chr(34) & "0%" & Chr(34) & ")"
Cells(3, 35).Value = "=IFERROR(SUMIFS(BE:BE,BB:BB," & Chr(34) & "=" & Chr(34) & Chr(38) & "A3,BC:BC," & Chr(34) & "=推广" & Chr(34) & "),0)"

sql输出顺序与条件一致的方法

strSQL_1 = strSQL_1 & "  WHERE a.id in  (" & memberArr & ") group by a.id order by FIELD(a.id," & memberArr & ")"

批量生成公式

'公式自动拷贝（纵向）
Set SourceRange = Range("F2:Q2")
Set fillRange = Range("F2:Q" & DSum)
SourceRange.AutoFill Destination:=fillRange
 '公式自动拷贝（横向）
Range("J71:J76").AutoFill Destination:=Range("O71:O76"), Type:=xlFillDefault

异常处理方法

'跳转到指定异常
On Error GoTo err_handle
'忽略异常继续执行
On Error Resume Next

删除重复记录行

Do
'删除重复数据（优先删除直入记录）
 If Cells(i + 1, 13).Value = Cells(i, 13).Value  Then
    duplicateDataSum = duplicateDataSum + 1
       If Cells(i, 5).Value = "直入" Then
             Rows(i & ":" & i).Select
       Else
             Rows(i + 1 & ":" & i + 1).Select
        End If
        Selection.Delete Shift:=xlUp
    Else
         i = i + 1
  End If
Loop Until Cells(i + 1, 1).Value = ""

常用mysql数据库查询方法

'定义数据源执行结果对象
Dim rstMain  As ADODB.Recordset
Set rstMain = New ADODB.Recordset
'执行sql获取结果，adLockOptimistic表示执行过程中，数据可以正常操作
rstMain.Open strSQL, oConn, 3, 3
'数据非空判断
If rstMain.EOF Then
    MsgBox "没有查询到任何数据！"
    Exit Function
Else
    '将查询结果，从A2开始放置到当前的excel中（比一条条的处理效率大幅提升）
    Range("A2").CopyFromRecordset rstMain
End If
'关闭数据库连接
rstMain.Close: Set rstMain = Nothing
oConn.Close: Set oConn = Nothing

当前日期前一天

Format(DateAdd("d", -1, Date), "yyyy-mm-dd")

对指定区域根据指定字段排序

Rows("2:" & j - 1).Select
ActiveWorkbook.Worksheets("地区统计").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("地区统计").Sort.SortFields.Add2 Key:=Range("C2:C" & j), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("地区统计").Sort
    .SetRange Range("A1:C" & j)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

API接口请求及返回数据解析方法

Function GetSEMDatafrombaiduapi(SDate As String, EDate As String)
    Dim Dstart_date As String, Dend_date As String
    '共通body信息
    Dsite_id = pc_baidu_siteid & "," & wap_baidu_siteid
    Dstart_date = SDate
    Dend_date = EDate
    'SEM的body信息
    SEMDmetrics = "show_count,clk_count,cost_count,visit_count,pv_count"
    SEMDmethod = "pro/product/a"
    SEMDarea = ""
    '初始化
    SEMReturnData = ""
    'SEM数据抽取及输出------------------------------------------------------------------
    SEM_pc_post_body = Chr(34) & "body" & Chr(34) & ":{" & Chr(34) & "site_id" & Chr(34) & ":" & Chr(34) & pc_baidu_siteid & Chr(34) & "," & Chr(34) & "start_date" & Chr(34) & ":" _
        & Chr(34) & Dstart_date & Chr(34) & "," & Chr(34) & "end_date" & Chr(34) & ":" & Chr(34) & Dend_date & Chr(34) & "," & Chr(34) & "metrics" & Chr(34) & ":" _
        & Chr(34) & SEMDmetrics & Chr(34) & "," & Chr(34) & "method" & Chr(34) & ":" & Chr(34) & SEMDmethod & Chr(34) & "," & Chr(34) & "area" & Chr(34) & ":" _
        & Chr(34) & SEMDarea & Chr(34) & "}}"
    SEM_wap_post_body = Chr(34) & "body" & Chr(34) & ":{" & Chr(34) & "site_id" & Chr(34) & ":" & Chr(34) & wap_baidu_siteid & Chr(34) & "," & Chr(34) & "start_date" & Chr(34) & ":" _
        & Chr(34) & Dstart_date & Chr(34) & "," & Chr(34) & "end_date" & Chr(34) & ":" & Chr(34) & Dend_date & Chr(34) & "," & Chr(34) & "metrics" & Chr(34) & ":" _
        & Chr(34) & SEMDmetrics & Chr(34) & "," & Chr(34) & "method" & Chr(34) & ":" & Chr(34) & SEMDmethod & Chr(34) & "," & Chr(34) & "area" & Chr(34) & ":" _
        & Chr(34) & SEMDarea & Chr(34) & "}}"
    sem_pc_post_data = post_header & "," & SEM_pc_post_body
    sem_wap_post_data = post_header & "," & SEM_wap_post_body
    'SEM的PC端数据请求
    With CreateObject("Microsoft.XMLHTTP")
        .Open "post", SentUrlv2, False
        .setRequestHeader "Content-type", "application/json;charset=utf-8"
        .Send sem_pc_post_data
        SEMpcReturnData = .responseText
    End With
    SEMArr = Split(Replace(Replace(Replace(SEMpcReturnData, "[[[", "],["), "[[", "["), "]]", "]"), "],[") '格式化json数据后存储到数组
    SEMsum = Split(SEMArr(5), ":[") '百度改版 4→5
    SEM = Split(Replace(SEMsum(0), Chr(34), ""), ",") '百度改版 2→1→0
    baidupcsem = Replace(SEM(3), "--", 0)
    baidupcsempv = Replace(SEM(4), "--", 0)
    'SEM的wap端数据请求(展现量\点击数\消费额是一样的，流量UV需分别获取)
    With CreateObject("Microsoft.XMLHTTP")
        .Open "post", SentUrlv2, False
        .setRequestHeader "Content-type", "application/json;charset=utf-8"
        .Send sem_wap_post_data
        SEMwapReturnData = .responseText
    End With
    SEMwapArr = Split(Replace(Replace(Replace(SEMwapReturnData, "[[[", "],["), "[[", "["), "]]", "]"), "],[") '格式化json数据后存储到数组
    SEMwapsum = Split(SEMwapArr(5), ":[") '百度改版 4→5
    SEMwap = Split(Replace(SEMwapsum(0), Chr(34), ""), ",") '百度改版 2→1→0
    baiduwapsem = Replace(SEMwap(3), "--", 0)
    baiduwapsempv = Replace(SEMwap(4), "--", 0)
    'Cells(52, 1).Value = SEMReturnData
    baidu_semshow = SEM(0) 'SEM展现量
    baidu_semclick = SEM(1) 'SEM点击量
    baidu_semconsume = SEM(2) 'SEM消费额
    baidu_semflow = baidupcsem + baiduwapsem  'SEM流量（pc+wap）:访问次数
    'Call ShowPercentMsg("通过百度API获取SEM数据中")
End Function

请求外部网站的方法

Sub help(control As IRibbonControl)
    Dim strURL As String
    '链接地址
    strURL = "https://www.imitker.com/"
    '调用本地浏览器
    Shell "explorer.exe " & strURL, 1
End Sub

通过outlook发送邮件

Sub mySendMail(ByVal to_who As String, ByVal cc_who As String, ByVal Subject As String, ByVal Body As String)
    Dim objOL As Object
    Dim itmNewMail As Object
    
    Application.DisplayAlerts = False
    
    '引用Microsoft Outlook 对象
    Set objOL = CreateObject("Outlook.Application")
    Set itmNewMail = objOL.CreateItem(olMailItem)
    On Error GoTo err_handle
    With itmNewMail
        .Subject = Subject  '主旨
        .htmlBody = Body    '正文本文
        .To = to_who  '收件者
        .CC = cc_who '抄送
        .BCC = "253@qq.com" '密送
        .Display  '启动Outlook发送窗口
        .Send '发送指令
    End With
    
    Set objOL = Nothing
    Set itmNewMail = Nothing
    Application.DisplayAlerts = True
    MsgBox ("邮件已发送")
err_handle:
    Set objOL = Nothing
    Set itmNewMail = Nothing
    On Error Resume Next
End Sub

获取当前工作簿所有工作表清单

Sheets.Add
For i = 1 To Sheets.Count
    Cells(i, 1).Value = Sheets(i).Name
Next i

批量获取工作簿名称

dim importFile(), importFileName As String
Sheets.Add
'打开文件
importFile = Application.GetOpenFilename("所有文件(*.*),*.*", , , , True)
 'If importFile = "False" Then Exit Sub
For i = 1 To UBound(importFile)
     'Set wk = GetObject(importFile(i)) '隐式打开文件
    
    For j = Len(importFile(i)) To 1 Step -1
        If InStr("\", Mid$(importFile(i), j, 1)) Then Exit For
    Next
    importFileName = Mid$(importFile(i), j + 1, Len(importFile(i)) - j)
    
    Cells(i, 1) = importFileName
Next i

阅读全文