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