VBA-自定义实用函数

（2017-07-02 银河统计）

  总结自定义VBA函数，补充《基于Office_VBA的数据处理、挖掘、建模及可视化的自动化框架设计》方案中相关函数，方便查找和应用。

目录概览

 1)数组写入其他工作簿中（注：说明文档中未修改）

 2)自动当前工作薄工作表的名称

 3)自动判断其他工作薄工作表的名称

 4)字典取唯一项

 5)sql 调取excel工作表数据

 6)自动取工作表的路径和名称

 7)sql调取excel工作表数据，返回数组数据结果

 8)语句8

 9)语句9

 10)语句10

 11)语句11

 12)语句12

 13)语句13

 14)语句14

 15)语句15

 16)语句16

 17)语句17

 18)语句18

---

1)数组写入其他工作簿中（注：说明文档中未修改）

    Public Function oWriteIntoExcel(ByVal oDataArr, ByVal parentFolderPath As String, ByVal DocumentName As String, ByVal oType As String, _
                 ByVal oSheet As String, ByVal oCellLocation As String, ByVal oColumn As Long, ByVal oTypeColumn As Long)
        
        Dim mypath As String
        mypath = parentFolderPath & DocumentName & "." & oType
        Application.DisplayAlerts = False
        Workbooks.Open mypath
        With Worksheets(oSheet)
            .Select
            If oTypeColumn = 1 Then
                Call oArrTransDataRY2(oDataArr, oSheet, oCellLocation, oColumn)
            ElseIf oTypeColumn = 2 Then
                Call oArrTransDataRYH1(oDataArr, oSheet, oCellLocation, oColumn)
            ElseIf oTypeColumn = 3 Then
                Call oArrTransDataRYS1(oDataArr, oSheet, oCellLocation, oColumn)
            End If
        End With
        ActiveWorkbook.Close SaveChanges:=True
        Application.DisplayAlerts = True
        
    End Function

2)自动当前工作薄工作表的名称

    Public Function oGetSheetName()
        
        Dim arr
        Dim i As Integer
        ReDim arr(0 To Sheets.Count - 1)
        For i = 0 To Sheets.Count - 1
            arr(i) = Sheets(i + 1).Name
        Next
        oGetSheetName = arr
        
    End Function

3)自动判断其他工作薄工作表的名称

    Public Function oGetOtherSheetName(ByVal parentFolderPath As String, ByVal DocumentName As String, ByVal oType As String)
        
        Dim arr
        Dim mypath As String
        Dim mysheet As String
        Dim i, n As Integer
        mypath = parentFolderPath & DocumentName & "." & oType
        mysheet = DocumentName & "." & oType                     
        Application.DisplayAlerts = False
        With GetObject(mypath)
            Workbooks(mysheet).Activate
            n = Workbooks(mysheet).Sheets.Count - 1
            ReDim arr(0 To n)
            For i = 0 To n
                arr(i) = Sheets(i + 1).Name
            Next
            .Close False
        End With
        Application.DisplayAlerts = True 
        oGetOtherSheetName = arr
        
    End Function

4)字典取唯一项

    Function dic_qc(Byval arr)
    
        Dim dic As Object
        Dim arr1, ra
        Dim n1, n2, i
        Set dic = CreateObject("Scripting.Dictionary")
        n1=UBound(arr)
        n2=LBound(arr)
        For i = n2 to n1
            ra=dic(arr(i))
        Next
        'Range("C2").Resize(dic.Count, 1)=Application.Transpose(dic.keys)
        'arr1=Application.Transpose(dic.keys)
        arr1=dic.keys
        dic_qc=arr1
    
    End Function
    

5)sql 调取excel工作表数据

    Sub data_group_by()
        
        'Sheets("原始数据").Select
        Dim conn As Object
        Dim sql, t
        Set t = Sheets("Sheet")
        Set conn = CreateObject("adodb.connection")
        conn.Open "dsn=excel files;dbq=" & ThisWorkbook.FullName
        sql = "select id, sum(A) from [Sheet$] group by id"
        t.[Z1].CopyFromRecordset conn.Execute(sql)
        conn.Close
        Set conn = Nothing
        MsgBox "分组统计已完成！", 64
        
    End Sub

6)自动取工作表的路径和名称

    path = ThisWorkbook.path & Application.PathSeparator
    name = ThisWorkbook.FullName

7)sql调取excel工作表数据，返回数组数据结果

    '------------------------
    'SELECT select_list
    '[ INTO new_table ]
    'From table_source
    '[ WHERE search_condition ]
    '[ GROUP BY group_by_expression ]
    '[ HAVING search_condition ]
    '[ ORDER BY order_expression [ ASC | DESC ] ]
    '
    '如果要改为之前我的那种说明方式，可以理解为：
    'Select 列名1,列名2,……
    '[Into 新表格名]
    'From 表格名
    '[Where {条件}]
    '[Group By 组合列名1,组合列名2,……]
    '[Having {组合条件}]
    '[Order By 排序列名1,排序列名2,…… [Asc|Desc]]
    '------------------------
    
    ' sql 调取excel工作表数据
    Public Function oGetDataSql(ByVal sql As String)
        
        On Error Resume Next
        Dim AdoConn As Object
        Dim AdoRst As Object
        
        Dim oArr1(), oArr2(), oArr3()
        Dim k, k1, k2 As Long
        Dim i As Long
        Dim oCount As Long
        Dim oArr
        Dim ii, jj As Long
        Dim n1, n2, n3, n4 As Long
        
        AdoConn.BeginTrans
        Set AdoConn = CreateObject("ADODB.connection")
        AdoConn.Open "DSN=EXCEL FILES;DBQ=" & ThisWorkbook.FullName
        Set AdoRst = AdoConn.Execute(sql)
        'Application.Wait Now() + TimeValue("00：00：02")
        oCount = AdoRst.Fields.Count - 1
        k2 = 0
        Do While Not AdoRst.EOF
            k1 = 0
            ReDim oArr1(0)
            For i = 0 To oCount
                ReDim Preserve oArr1(0 To k1)
                oArr1(k1) = AdoRst(i)
                k1 = k1 + 1
            Next
            ReDim Preserve oArr2(0 To oCount, 0 To k2)
            For i = 0 To oCount
                oArr2(i, k2) = oArr1(i)
            Next
            k2 = k2 + 1
            AdoRst.MoveNext
        Loop
        '    可以取结果的名字
        '    k = 0
        '    For i = 0 To oCount
        '        ReDim Preserve oArr3(0 To k)
        '        oArr3(k) = AdoRst(i).Name
        '        k = k + 1
        '    Next
        AdoConn.CommitTrans
        
        '数组oArr2 | 行列转置+去掉oArr2第一列的空值null
        n1 = LBound(oArr2, 1)
        n2 = UBound(oArr2, 1)
        n3 = LBound(oArr2, 2)
        n4 = UBound(oArr2, 2)
        ReDim oArr(n3 To n4 - 1, n1 To n2)
        For ii = n1 To n2
            For jj = n3 To n4
                oArr(jj, ii) = oArr2(ii, jj + 1)
            Next
        Next
        
        If Not AdoRst Is Nothing Then
            If AdoRst.State = 1 Then
               AdoRst.Close
            End If
            Set AdoRst = Nothing
        End If
        AdoConn.Close
        Set AdoConn = Nothing
        oGetDataSql = oArr
        'MsgBox "分组统计已完成！", 64
        
    End Function
    
    '-----------------------
    
    Sub test()
    
        Dim sql, arr
        'sql = "select id As oID, sum(A) As oSum, count(B) As oCount, avg(C) As oAvg, max(D) As oMax, min(E) As oMin from [Sheet$] group by id"
        sql = "select id, sum(A), count(B), avg(C), max(D), min(E) from [Sheet$] group by id"
        arr = oGetDataSql(sql)
    
    End Sub
    '------------------------

8)语句8

9)语句9

10)语句10

11)语句11

12)语句12

13)语句13

14)语句14

15)语句15

16)语句16

17)语句17

18)语句18

转载于:https://www.cnblogs.com/cloudtj/articles/7107492.html