本日はVBA！ADOを用いて、別ファイル(エクセルやCSV)を取り込む操作です。
今回のSQLは SELECT ALLなのであれですけども、
複雑なのやファイルによって変動させたりする場合はDebug.Printでイミディエイトに出力した方がメンテしやすいです。
実行環境 MicroSoft Office 2010 Professional Plus 2010
ドラッグ＆ドロップで取り込む
事前準備
今回データの取り込み口はリストビューとして、ここにD&Dで取り込んでいきます。
Alt+F11 でVBE (Visual Basic Editor) を開きます。
参照設定はこんな感じになってます
※64Bit版Excelは残念ながらリストビュー使えません。
参照設定を追加したら、まず初めにフォームを作成します。
ポイントはOLEDropModeをccOLEDropManualにするべし。
次は取り込み先のファイルを適当に作成します。
次に、呼び出し方は何でも大丈夫ですが、今回はボタンを配置して、
ここからフォームを呼び出してみます。
コード本文
準備が出来たら次はフォーム本体に下記コードを入力します。コピペでOK！
Option Explicit
'*******************************************************************
'* ADOドラッグ＆ドロップ時処理
'*******************************************************************
Private Sub ListView_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim strSql As String ' Sql文字列
Dim strSqlFromSuffix As String ' From句接尾文字設定
Dim strAddress As String ' Fileパス
Dim strFileName As String ' File名
Dim strExtension As String ' 拡張子文字列
Dim dbCon As ADODB.Connection ' ADODB.Connection
Dim dbRes As ADODB.Recordset ' ADODB.Recordset
Set dbCon = New ADODB.Connection
Set dbRes = New ADODB.Recordset
' ファイルパスとファイル名を取得
strAddress = Left(Data.Files(1), InStrRev(Data.Files(1), "\"))
strFileName = Mid(Data.Files(1), InStrRev(Data.Files(1), "\") + 1)
' ファイル拡張子取得
strExtension = LCase(CreateObject("Scripting.FileSystemObject").GetExtensionName(strAddress + strFileName))
' 拡張子分岐
Select Case strExtension
' CSVの場合
Case "csv"
dbCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strAddress & ";" & _
"Extended Properties=""Text;HDR=YES;FMT=Delimited"""
strSqlFromSuffix = ".csv]" & vbCr
' その他(厳密にやるならxlsとかxlsxとか指定しましょう)
Case Else
dbCon.Provider = "Microsoft.ACE.OLEDB.12.0"
dbCon.Properties("Extended Properties") = "Excel 12.0"
dbCon.Open strAddress + strFileName
strSqlFromSuffix = "$]" & vbCr
End Select
' Sql作成 ※ここのSheet1は取り込み対象とするシート名
strSql = "SELECT * FROM [" + "Sheet1" + strSqlFromSuffix
' SQLを実行
dbRes.CursorLocation = adUseClient
dbRes.Open strSql, dbCon, adOpenDynamic, adLockOptimistic, adCmdText
' A2に貼り付け
Worksheets("Sheet1").Range("A2").CopyFromRecordset dbRes
' A1に見出行書き出し
Dim wkCnt As Integer
For wkCnt = 1 To dbRes.Fields.Count
Worksheets("Sheet1").Cells(1, wkCnt) = dbRes.Fields(wkCnt - 1).Name
Next
' 閉じる
dbRes.Close
dbCon.Close
' お掃除
Set dbRes = Nothing
Set dbCon = Nothing
End Sub
最後にSheet1上のボタンを押してフォームを呼び出し作成したエクセルをD&D！
いとも簡単に取り込みが完了します。
CSV取り込み時の注意事項
取り込む時にデータ型を明示的に指定したり変更は出来ず、
頭から8行(デフォルトの場合。 1 ～ 16に変更も可)をスキャンしてフィールドのデータ型を勝手に決めつけてきます。
この超絶極悪仕様により、例えばもしも数値カラムであると判断されてしまった場合、
そのカラムの中に文字列レコードが存在していたらそのレコードだけが消えてしまうのです。 まさに外道。
そんな時はここは文字列だよ！と強制的に認識させる為に頭に1文字(何でもいい)付与するか、
下記のようにFileSystemObjectを使い、全て読み取り別シートに張り付けた上でADO接続します。
Option Explicit
'*******************************************************************
'* 文字列と数値混合カラムCSV対抗策
'*******************************************************************
Private Sub ListView_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim fso As New Scripting.FileSystemObject
Dim csvFile As Object ' CSV実体
Dim splitcsvData As Variant ' CSV一時格納用
Dim strAddress As String ' Fileパス
Dim strFileName As String ' File名
Dim nRowCnt As Long ' レコードカウント
Dim nColCnt As Long ' カラムカウント
' ファイルパスとファイル名を取得
strAddress = Left(Data.Files(1), InStrRev(Data.Files(1), "\"))
strFileName = Mid(Data.Files(1), InStrRev(Data.Files(1), "\") + 1)
' CSVファイルを開く
Set csvFile = fso.OpenTextFile(strAddress + strFileName, 1)
' 初期値
nRowCnt = 1
' AtEndOfStreamがFalseの間ループ、最後まで行ったらTrueになる
Do While csvFile.AtEndOfStream = False
' CSVファイルの1行を読み込みカンマ区切りで配列化
splitcsvData = Split(csvFile.ReadLine, ",")
wkColCnt = UBound(splitcsvData) + 1
Sheets("Sheet2").Range(Sheets("Sheet2").Cells(nRowCnt, 1), Sheets("Sheet2").Cells(nRowCnt, nColCnt)).Value = splitcsvData
nRowCnt = nRowCnt + 1
Loop
End Subこうすれば一旦すべてのデータを抜けるので、ここからSQLで細かい指定を行い書き換えてやりましょう。
まとめ
使いこなせれば非常ーに強力な手段です。
ただし、エクセル等からの取り込みの場合は綺麗な表形式になっていないことが多いので、
それらに耐える事が出来る汎用的な作りにする事且つ、
VBAが分からない人でも簡単にメンテ出来るような作りを心がけましょう！
コメント