VBA 汎用SQL実行ツール

シートSQLに記入したSQLを実行して、先頭シートに検索結果を展開(表化)するツールを考えました。
ACCESS版　SQL実行(EXCEL VBA)の改良版(簡略化しました)です。
シンプルに考えると、
基本的にORACLE検索系のVBAで僕がしたいのは、
こういうことだったのだ・・・ということで。

**************************************************************************
Option Explicit

Declare Function SetCurrentDirectory Lib "kernel32" Alias _
　　　　　　　　"SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long

Sub SQL_RUN()
　 Dim adoCn　As ADODB.Connection: Set adoCn = New ADODB.Connection
　 Dim adoRs　As ADODB.Recordset: Set adoRs = New ADODB.Recordset
　 Dim i　　　As Integer: i = 1
　 Dim strSQL As String: strSQL = ""
' Dim strUID As String: strUID = "ADMINISTRATOR"　　　　　　　　 ' ユーザー
' Dim strPWD As String: strPWD = "ADMINPWD" 　　　　　　　　　　 ' パスワード
' Dim strSID As String: strSID = "ORCL"　　　　　　　　　　　　　' Service-Name
　 Dim strDSN As String: strDSN = ThisWorkbook.Path & "\TEST.dsn" ' DSNファイル名
　 On Error GoTo ErrHandler
　 SetCurrentDirectory ThisWorkbook.Path
　 Application.ScreenUpdating = False
' SQL読込み(SQLシート)
　 Sheets("SQL").Visible = True
　 Sheets("SQL").Select
　 Do While Cells(i, 1) <> ""
　　　strSQL = strSQL + Cells(i, 1).Value
　　　i = i + 1
　 Loop
　 If strSQL = "" Then Exit Sub
　 Sheets("SQL").Visible = False
　 Sheets(1).Select
　 Call BorderClear　 ' 罫線クリア
' DB接続　環境により設定
' (TNSNames.ora)<== 参考
' adoCn.Open "Provider=MSDAORA;Data Source=(DESCRIPTION=(ADDRESS_LIST=(ADDRESS=" & _
' 　　　　　　"(PROTOCOL=TCP)(HOST=localhost)(PORT=1521)))" & _
' 　　　　　　"(CONNECT_DATA=(SERVICE_NAME=" & strSID & ")));", strUID, strPWD
' (ODBC-ORACLE)<== 参考
' adoCn.Open "FileDSN=" & strDSN & ";UID=" & strUID & ";PWD=" & strPWD & ";"
' (ODBC-ACCESS)<== これでテストしている
　 adoCn.Open "FileDSN=" & strDSN & ";"
' SQL実行
　 adoRs.Open strSQL, adoCn, adOpenStatic, adLockReadOnly
' 見出しセット（未設定のとき）
　 If Range("A1").Value = "" Then
　　　For i = adoRs.Fields.Count To 1 Step -1
　　　　 Cells(1, i).Value = adoRs.Fields(i - 1).Name
　　　Next i
　 End If
' SQL検索結果セット
　 Range("A2").CopyFromRecordset adoRs
' DB切断
　 adoRs.Close
　 adoCn.Close
　 Set adoRs = Nothing
　 Set adoCn = Nothing
　 Call BorderSet　　 ' 罫線描画
　 Call FormatSet　　 ' 書式設定(見出しセルに指定した書式を同列に設定する)
　 RANGE("A2").select
　 Application.ScreenUpdating = True
　 Exit Sub
ErrHandler:
　 If Err.Number = 3709 Then Exit Sub
　 MsgBox Err.Description & " " & Err.Number
　 Resume Next
End Sub

' 罫線クリア
Private Sub BorderClear()
　 If Cells(2, 1).Value = "" Then Exit Sub
　 Dim MaxRow As Long:　　MaxRow = Range("A2").End(xlDown).Cells.Row
　 Dim MaxCol As Integer: MaxCol = Range("A1").End(xlToRight).Cells.Column
　 Range(Cells(2, 1), Cells(MaxRow, MaxCol)).Select
　 Selection.Borders.LineStyle = xlNone
　 Selection.ClearContents
End Sub

' 罫線描画
Private Sub BorderSet()
　 If Cells(2, 1).Value = "" Then Exit Sub
　 Dim MaxRow As Long:　　MaxRow = Range("A2").End(xlDown).Cells.Row
　 Dim MaxCol As Integer: MaxCol = Range("A1").End(xlToRight).Cells.Column
　 Range(Cells(2, 1), Cells(MaxRow, MaxCol)).Select
　 Selection.Borders.LineStyle = xlContinuous
End Sub

' 書式設定(見出しセルに指定した書式を同列に設定する)
Private Sub FormatSet()
　 Dim i　　　 As Integer: i = 1
　 Dim strTEXT As String
　 Do While Cells(1, i).Value <> ""
　　　If Cells(1, i).NumberFormatLocal <> "G/標準" And _
　　　　 Cells(1, i).NumberFormatLocal <> Cells(2, i).NumberFormatLocal Then
　　　　 strTEXT = Cells(1, i).NumberFormatLocal
　　　　 If strTEXT = "yyyy/mm/dd;@" Then
　　　　　　Columns(i).Select
　　　　　　Selection.HorizontalAlignment = xlCenter
　　　　　　Selection.NumberFormatLocal = "yyyy/mm/dd;@"
　　　　　　With Selection.FormatConditions
　　　　　　　.Delete
　　　　　　　.Add Type:=xlExpression, Formula1:="=AND(MONTH(RC[])>9,DAY(RC[])<10)"
　　　　　　　.Add Type:=xlExpression, Formula1:="=AND(MONTH(RC[])<10,DAY(RC[])>9)"
　　　　　　　.Add Type:=xlExpression, Formula1:="=AND(MONTH(RC[])<10,DAY(RC[])<10)"
　　　　　　　.Item(1).NumberFormat = "yyyy/mm/_0d;@"
　　　　　　　.Item(2).NumberFormat = "yyyy/_0m/dd;@"
　　　　　　　.Item(3).NumberFormat = "yyyy/_0m/_0d;@"
　　　　　　End With
　　　　 Else
　　　　　　Columns(i).Select
　　　　　　Selection.NumberFormatLocal = strTEXT
　　　　 End If
　　　End If
　　　i = i + 1
　 Loop
End Sub

' シート書出し
Sub SheetOut()
　 Sheets(1).Select
　 If Cells(2, 1).Value = "" Then
　　　MsgBox "このシートにはデータがありません！"
　　　Exit Sub
　 End If
　 Dim strFileName As String
　 Dim i　　　　　 As Integer
　 SetCurrentDirectory ThisWorkbook.Path
　 strFileName = ThisWorkbook.Path & "\" & Replace(ThisWorkbook.Name, "xlsm", "")
　 If Dir(strFileName & ".xlsx") <> "" Then
　　　strFileName = strFileName & "_" & Replace(Time$, ":", "")
　 End If
　 Worksheets(1).Move
　 For i = ActiveSheet.Shapes.Count To 1 Step -1
　　　If ActiveSheet.Shapes(i).Type = msoFormControl Then ActiveSheet.Shapes(i).Delete 'ボタンを削除
　 Next i
　 Call ListSet　　　 ' テーブルスタイル設定
　 ActiveWorkbook.Worksheets(1).Name = Date$
　 Range("A2").Select
　 ActiveWorkbook.SaveAs Filename:=strFileName & ".xlsx", FileFormat:=xlWorkbookDefault
　 ThisWorkbook.Close savechanges:=False
End Sub

' テーブルスタイル設定
Private Sub ListSet()
　 Dim Ret As Variant
　 Worksheets(1).Select
　 Range("A1").Select
　 Range(Selection, Selection.End(xlToRight)).Select
　 Range(Selection, Selection.End(xlDown)).Select
　 Ret = ActiveSheet.ListObjects.Add(SourceType:=xlSrcRange, _
　　　　 Source:=Selection.Cells, xllistobjecthasheaders:=xlYes)
　 With ActiveSheet.ListObjects(1)
　　 Select Case Int(Rnd * 3)
　　 Case 0
　　　 .TableStyle = "TableStyleLight" & Int(Rnd * 20 + 1)
　　 Case 1
　　　 .TableStyle = "TableStyleMedium" & Int(Rnd * 27 + 1)
　　 Case 2
　　　 .TableStyle = "TableStyleDark" & Int(Rnd * 10 + 1)
　　 End Select
　End With
End Sub