本日は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！
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
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接続します。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
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が分からない人でも簡単にメンテ出来るような作りを心がけましょう！
コメント