#VBA笔记

  • 基本

    • 函数表达式 作用
      Application.DisplayAlerts = False/True 是否提示警告
      Application.ScreenUpdating = False/True 是否更新屏幕
      Debug.Print () 输出到控制台
      Msgbox () 弹框

  • Application函数

    • application

      • 函数表达式 作用
        userName 获取当前用户名(Jpanda)

  • 工作表函数

    • Application.WorksheetFunction.

      • 函数表达式 作用
        Max(arr) 求数组最大值
        Match("target",arr) 找出数组中某元素的索引

  • VBA函数

    • VBA.

      • 函数表达式 作用
        Format("2020/01/01", "yyyy-MM-dd") 格式化字符串
        Split("2020/01/01", "/")(0) 分割字符串

  • 单元格操作

    • 函数表达式 作用
      Range("A1:C10") 定义范围
      Range("A" & i) 动态单元格
      Cells(x,y) 单元格
      Cells 所有单元格
      Cells(Rows.Count, 1).End(xlUp).Row 最后非空行行号
      Cells(1, Columns.Count).End(xlToLeft).Column 最后非空列列号

  • 表操作

    • 通过名称增加表到最后

      • Public Sub AddSheetByNameAfter(sheetName As String)
    Dim st, addSt As Worksheet
    Dim existSheet As Boolean
    existSheet = False
    For Each st In ActiveWorkbook.Sheets
        If st.name = sheetName Then
           existSheet = True
        End If
    Next
    If Not existSheet Then
        Set addSt = ActiveWorkbook.Worksheets.add(, Sheets(Sheets.Count))
        addSt.name = sheetName
    Else
        MsgBox ("SheetName" + sheetName + ":Exist!")
    End If
End Sub

    • 通过名称删除表

      • Public Sub DeleteSheetByName(sheetName As String)
    Dim st As Worksheet
    For Each st In ActiveWorkbook.Sheets
        If st.name = sheetName Then
            Application.DisplayAlerts = False
            st.Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next
    MsgBox ("SheetName" + sheetName + ":Is Not Exist!")
End Sub

    • 复制Sheet1到最后并改名

      • Public Function CopySheetBySheet1(sheetName As String) As Boolean
    Dim st, addSt As Worksheet
    Dim existSheet As Boolean
    existSheet = False
    For Each st In ActiveWorkbook.Sheets
        If st.name = sheetName Then
           existSheet = True
        End If
    Next
    If Not existSheet Then
        ActiveWorkbook.Worksheets("Sheet1").Copy After:=Sheets(Sheets.Count)
        ActiveSheet.name = sheetName
        CopySheetBySheet1 = True
    Else
        CopySheetBySheet1 = False
    End If
End Function

    • 复制Sheet1到最后并改名,改名规则为某个前缀加序号递增

      • Public Sub addSheetBySort(prefix As String)
    Dim i As Integer
    Dim success As Boolean
    i = 1
    success = False
    Do While (Not success)
        success = CopySheetBySheet1(prefix & i)
        i = i + 1
    Loop
End Sub

  • 控制语句

    • If

      • Dim i As Integer
i = 3
If i = 1 Then
    Debug.Print (1)
ElseIf i = 2 Then
    Debug.Print (2)
Else
    Debug.Print (3)
End If

    • For

      • Dim i, sum As Integer
For i = 1 To 200
    sum = sum + i
    If i = 100 Then
        Exit For
    End If
Next
Debug.Print (sum)

    • For Each In

      • Dim st As Worksheet
For Each st In ThisWorkbook.Sheets
    Debug.Print (st.name)
Next

    • Do While() Loop

      • Dim i, sum As Integer
Do While (i <= 100)
    sum = sum + i
    i = i + 1
Loop
Debug.Print (sum)

    • Do Until() Loop

      • Dim i, sum As Integer
Do Until (i > 100)
    sum = sum + i
    i = i + 1
Loop
Debug.Print (sum)

    • Do Loop Until()

      • Dim i, sum As Integer
Do
    sum = sum + i
    i = i + 1
Loop Until (i > 100)
Debug.Print (sum)

    • While Wend

      • Dim i, sum As Integer
While i <= 100
  sum = sum + i
    i = i + 1
Wend
Debug.Print (sum)

  • 窗体

    • 方法

      '显示窗口
win.Show(0/1)
'隐藏窗口
win.Hide
'卸载窗口
Unload win

    • 属性

  • 数组

    • 定义

      • 常量数组

      • Dim arr()
arr = Array("a", "b", "c")

      • 静态数组

      • Dim arr0()
Dim arr1(4)
Dim arr2(1 To 5)
Dim arr3(1 To 5,1 To 2)

      • 数组赋值和使用

      • '给数组赋值
arr = Range("A1:D10")
arr(index)=value
'使用数组元素
Range("A1:D10") = arr
Range("A1") = arr(index)
'动态改变数组大小
ReDim Preserve arr(1 To n)

      • 数组界限

      • LBound(arr, 1)
UBound(arr, 1)
LBound(arr, 2)
UBound(arr, 2)

      • 清空数组

      • Erase arr

  • 文件操作

    • 读写

      •   
'读取文件为字符串
Public Function ReadFileToString(filename As String) As String
    Dim ret, temp As String
    Dim filenum As Integer
    '自动获取一个未占用文件号
    filenum = FreeFile
    '打开文件
    Open filename For Input As #filenum
    Do While Not EOF(filenum)
        temp = Input(1, filenum)
        ret = ret + temp
    Loop
    '关闭文件
    Close #filenum
    ReadFileToString = ret
End Function

'读取文件每行放入数组
Public Function ReadFileToArray(filename As String) As String()
    Dim ret() As String, temp As String
    Dim filenum, lines As Integer
    filenum = FreeFile
    lines = 0
    Open filename For Input As #filenum
    Do While Not EOF(filenum)
        lines = lines + 1
        '动态改变数组大小
        ReDim Preserve ret(1 To lines) As String
        Line Input #filenum, ret(lines)
    Loop
    Close #filenum
    ReadFileToArray = ret
End Function

'写入一句话到文件追加或者新建,Optional为可选参数,不填写使用默认值
Public Sub WriteStringToFile(filename As String, outputstring As String, Optional useappend As Boolean = True)
    Dim ret() As String, temp As String
    Dim filenum, lines As Integer
    filenum = FreeFile
 
    If useappend Then
        Open filename For Append As #filenum
        Write #filenum, outputstring
    Else
        Open filename For Output As #filenum
        Write #filenum, outputstring
    End If
    
    Close #filenum
End Sub

'读写二进制小文件
Public Sub CopyBinaryFile(source As String, target As String)
    Open source For Binary As #1
    Open target For Binary As #2
    Dim i As Long, bte As Byte
    bte = 255
    For i = 1 To LOF(1)
        Get #1, , bte
        Put #2, LOF(2) + 1, bte
    Next
    Close #1
    Close #2
End Sub

  • FTP

    • 使用winscp.com下载文件

      • Sub sftpget()
    Dim winscppath, env_addr, env_user, env_passwd, localftp, cfgfile, retfile, ftpfile As String
    'winscp路径
    winscppath = "C:\Program Files (x86)\WinSCP\winscp.com"
    'IP地址
    env_addr = "192.168.131.102"
    '用户名
    env_user = "root"
    '用户密码
    env_passwd = "root"
    '本地存储路径
    localftp = "C:\Users\77023\Desktop\test\"
    '配置文件路径
    cfgfile = "C:\Users\77023\Desktop\test\config.txt"
    '结果文件名
    retfile = "ret.txt"
    
    '下载目标文件路径
    ftpfile = "/opt/SogouQ1.txt"
    
    '生成脚本文件
    Open cfgfile For Output As #1
    '打开连接
    Print #1, "open sftp://" & env_user & ":" & env_passwd & "@" & env_addr
    '下载文件
    Print #1, "get " & ftpfile & " " & localftp & retfile
    '关闭脚本
    Print #1, "close"
    Close #1
    
    '执行脚本文件
    Shell winscppath & " " & "/script=" & cfgfile, 0
    '等待下载完成
    Do While Dir(localftp & retfile) = Empty
        DoEvents
    Loop
    MsgBox "下载完成"
End Sub

  • 类模块

    • 本类Panda

      • Private clsAuthor As String
Private clsAge As Integer

Public Sub DeleteSheetByName(sheetName As String)
    Dim st As Worksheet
    For Each st In ActiveWorkbook.Sheets
        If st.name = sheetName Then
            Application.DisplayAlerts = False
            st.Delete
            Application.DisplayAlerts = True
            Exit For
        End If
	Next
	MsgBox ("SheetName" + sheetName + ":Is Not Exist!")
End Sub

Public Sub AddSheetByNameAfter(sheetName As String)
    Dim st, addSt As Worksheet
    Dim existSheet As Boolean
    existSheet = False
    For Each st In ActiveWorkbook.Sheets
        If st.name = sheetName Then
            existSheet = True
        End If
    Next
    If Not existSheet Then
    Set addSt = ActiveWorkbook.Worksheets.add(, Sheets(Sheets.Count))
        addSt.name = sheetName
    Else
        MsgBox ("SheetName" + sheetName + ":Exist!")
    End If
End Sub

Public Function add(a As Integer, b As Integer)
    add = a + b
End Function

Property Get author() As Variant
    author = clsAuthor
End Property

Property Let author(ByVal vNewValue As Variant)
    clsAuthor = vNewValue
End Property

Public Property Get age() As Variant
    age = clsAge
End Property

Public Property Let age(ByVal vNewValue As Variant)
    clsAge = vNewValue
End Property

Public Sub InitiateProperties(author As String, age As Integer)
    clsAuthor = author
    clsAge = age
End Sub

Private Sub Class_Initialize()
    Debug.Print ("Panda Initialize...")
End Sub

Private Sub Class_Terminate()
    Debug.Print ("Panda Terminate...")
End Sub

    • 工厂类Factory

      •   Public Function CreatePanda(author As String, age As Integer) As panda
      Set CreatePanda = New panda
      CreatePanda.InitiateProperties author:=author, age:=age
  End Function

    • 调用类

      • Sub main()
    Dim pd As panda
    Dim factory As factory
    Set factory = New factory
    Set pd = factory.CreatePanda("lj", 26)
    Debug.Print (pd.age)
    Debug.Print (pd.author)
    pd.age = 27
    pd.author = "panda"
    Debug.Print (pd.age)
    Debug.Print (pd.author)
    pd.AddSheetByNameAfter sheetName:="test"
    pd.DeleteSheetByName sheetName:="ss"
    Debug.Print (pd.add(1, 2))
End Sub

  • Excel功能集对应excel操作

    • 设置打印区域

      • ActiveSheet.PageSetup.PrintArea = Cells(1, 1).CurrentRegion.Address + ":" + Cells(row, col).CurrentRegion.Address

  • ADO数据库操作

    1. 连接PostgreSQL

      • Sub postgreSQLConn()
    '需要打开MicroSoft Activx Data Objects
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim dataSource As String
    Dim userName As String
    Dim password As String
    Dim DBname As String
    Dim ConnProperty As String
    Dim SQL As String
    Dim arr()
    
    dataSource = "PostgreSQLODBC"
    userName = "postgres"
    password = "Panda5201314"
    DBname = "panda"
    'DSN=PostgreSQLODBC;UID=postgres;PWD=Panda5201314;Database=panda
    ConnProperty = "DSN=" & dataSource & ";" & "UID=" & userName & ";" & "PWD=" & password & ";" & "Database=" & DBname
    
    '开启连接
    conn.Open ConnProperty

    '検索
    SQL = "select * from student where sid='01'"
    Set rs = conn.Execute(SQL)

    '遍历结果集
    Do While (Not rs.EOF)
        Debug.Print (rs.Fields("sid").Value)
        Debug.Print (rs.Fields(1).Value)
        Debug.Print (VBA.Split(rs.Fields(2).Value, "/")(0))
        rs.MoveNext
    Loop
    
    '将数据集写入Excel表中
    'arr = rs.GetRows
    '横式
    'Sheet2.Range("a1").Resize(UBound(arr, 2) + 1, UBound(arr, 1) + 1) = Application.WorksheetFunction.Transpose(arr)
    '列式
    'Sheet2.Range("a1").Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1) = arr
    
    '关闭资源
    rs.Close
    conn.Close
    Set rs = Nothing
    Set cn = Nothing
    
    '削除
    'Call conn.Execute(SQL)
    
    '修正
    'Call conn.Execute(SQL)
End Sub