SIBAINUのメモ帳

ビッグデータの抽出

ビッグデータの抽出をSQLを使用して抽出するためのプロシージャーで、接続から簡単なSQL文を作成して抽出まで行っています。

COPY

Public Sub ExcelConnect()
    Const adOpenKeyset = 1
    Const adOpenStatic = 3
    Const adLockReadOnly = 1

    Dim dbCon As Object
    Dim dbRs As Object
    Dim strSQL As String

    Set dbCon = CreateObject("ADODB.Connection")
    Set dbRs = CreateObject("ADODB.Recordset")
    dbCon.Provider = "Microsoft.ACE.OLEDB.12.0"
    'HDR YES:シートの１行目をヘッダ列として扱う、NO:１行目から行データとして扱う フィールド名は、F+列番号
    'IMEX 0:エクスポート モード、1:インポート モード、2:リンク モード
    dbCon.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"
    dbCon.Open ThisWorkbook.FullName

    strSQL = ""
    strSQL = strSQL & "SELECT F1, F2 "
    'Sheet1のA2:B1001を対象とする
    strSQL = strSQL & " FROM [Sheet1$A2:B1001] "    'Cells(1,1)からシート全体を取得したい場合 [Sheet1$]
    strSQL = strSQL & " WHERE F2 > 40000 "
    strSQL = strSQL & " ORDER BY F2;"
    dbRs.Open strSQL, dbCon, adOpenStatic, adLockReadOnly
    
    'HDR=YESとした場合、フィールド名をセットする
    'For i = 0 To dbRs.Fields.Count - 1
    '    Sheet1.Cells(1, 10 +i).Value = dbRs.Fields(i).Name
    'Next i
    Sheet1.Cells(2, 10).CopyFromRecordset dbRs

    dbRs.Close
    Set dbRs = Nothing

    dbCon.Close
    Set dbCon = Nothing

End Sub

エクセルへの接続

列ヘッダーを結果セットに読み込み（ヘッダーがあってもHDR = NOを使用）、列データが数値である場合は、IMEX = 1を使用してクラッシュを回避します。IMEX = 1を常に使用することは、混合データ列のデータを取得するより安全な方法です。

COPY

Public Sub ExcelConnect()
    Const adOpenKeyset = 1
    Const adOpenStatic = 3
    Const adLockReadOnly = 1

    Dim dbCon As Object
    Dim dbRs As Object
    Dim strSQL As String

    Set dbCon = CreateObject("ADODB.Connection")
    Set dbRs = CreateObject("ADODB.Recordset")
    dbCon.Provider = "Microsoft.ACE.OLEDB.12.0"
    'HDR YES:シートの１行目をヘッダ列として扱う、NO:１行目から行データとして扱う フィールド名は、F+列番号
    'IMEX 0:エクスポート モード、1:インポート モード、2:リンク モード
    dbCon.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"
    dbCon.Open ThisWorkbook.FullName

    strSQL = ""
    strSQL = strSQL & "SELECT F1, F2 "
    'Sheet1のA2:B1001を対象とする
    strSQL = strSQL & " FROM [Sheet1$A2:B1001] "    'Cells(1,1)からシート全体を取得したい場合 [Sheet1$]
    strSQL = strSQL & " WHERE F2 > 40000 "
    strSQL = strSQL & " ORDER BY F2;"
    dbRs.Open strSQL, dbCon, adOpenStatic, adLockReadOnly
    
    'HDR=YESとした場合、フィールド名をセットする
    'For i = 0 To dbRs.Fields.Count - 1
    '    Sheet1.Cells(1, 10 +i).Value = dbRs.Fields(i).Name
    'Next i
    Sheet1.Cells(2, 10).CopyFromRecordset dbRs

    dbRs.Close
    Set dbRs = Nothing

    dbCon.Close
    Set dbCon = Nothing

End Sub

エクセルへの接続

COPY

Excel 2007以降

Xlsx files
Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\myFolder\myExcel2007file.xlsx;
Extended Properties="Excel 12.0 Xml;HDR=YES";

Treating data as text
Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\myFolder\myExcel2007file.xlsx;
Extended Properties="Excel 12.0 Xml;HDR=YES;IMEX=1";

Xlsb files
Provider=Microsoft.ACE.OLEDB.12.0;
Data Source=c:\myFolder\myBinaryExcel2007file.xlsb;
Extended Properties="Excel 12.0;HDR=YES";

Xlsm files
Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\myFolder\myExcel2007file.xlsm;
Extended Properties="Excel 12.0 Macro;HDR=YES";

VBScriptの使用例

VBScriptの使用例です。大部分が定型コードです。スクリプトの前半部分では、いくつか定数を定義し、2 つのオブジェクト (ADODB.Connection と ADODB.Recordset) を作成していることを説明するぐらいでしょう。これらのオブジェクトは、データに接続したり、データソースからデータを取得するのに必要です。これらの大部分は、ADO スクリプト内で手を加えないでそのまま使用する定型コードです。注意するのは、"Data Source" の部分のみです。この部分では、使用するワークシートへのパスを指定します。ワークシートへのパスに空白が含まれていたらどうなるでしょう。この場合は、まったく問題がないので、次のようにファイルパス全体を空白なども一緒に記述します。

COPY

On Error Resume Next

Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H0001

Set objConnection = CreateObject("ADODB.Connection")
Set objRecordSet = CreateObject("ADODB.Recordset")

ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=C:\Scripts\Test.xls;" & _
        "Extended Properties=""Excel 8.0;HDR=Yes;"";" 
objConnection.Open ConnectionString 

objRecordset.Open "Select * FROM [Sheet1$] Where Number = 2", _
    objConnection, adOpenStatic, adLockOptimistic, adCmdText

Do Until objRecordset.EOF
    Wscript.Echo objRecordset.Fields.Item("Name"), _
        objRecordset.Fields.Item("Number")
    objRecordset.MoveNext
Loop

ADO プロバイダ

「Excel ではなく、Excel へのアクセスに使用される ADO プロバイダを指します。プロバイダを Excel 8.0 のままにしておくことで、すべてがうまくいきます。(https://technet.microsoft.com/ja-jp/library/ee692882.aspx)」と言っているので、下記のようにしない方がいいかも。

COPY

objConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=C:\Scripts\Test.xls;" & _
        "Extended Properties=""Excel 12.0;HDR=Yes;"";"

「ShellExecuteEX」関数

COPY

'----------------------------------------------------------------------ShellExecuteEX
    'SHELLEXECUTEINFO構造体の定義をします。
#If VBA7 And Win64 Then
  '64ビット版
    Public Type SHELLEXECUTEINFO
        cbSize                  As Long                     '構造体のサイズ
        fMask                   As Long                     '処理制御フラグ。2つ以上設定するときはOr演算子で結びます。
        hwnd                    As LongPtr                  'ShellExecuteEXを呼び出すウィンドウのハンドル
        lpVerb                  As String                   '処理制御文字列。指定しないときは"open"になります。
        lpFile                  As String                   '起動するファイルの名前
        lpParameters            As String                   '起動する実行可能ファイルへのパラメータ（lpFileメンバが実行可能ファイルのとき）。
        lpDirectory             As String                   '作業用ディレクトリ。設定しないときはカレントディレクトリになります。
        nShow                   As Long                     '起動する実行ファイルのウィンドウの状態
        hInstApp                As LongPtr                  '33以上の値のときはインスタンスハンドル、32以下の値では下表に示すエラー値
        lpIDList                As LongPtr                  'ITEMIDLIST構造体のアドレス。fMaskメンバにSEE_MASK_IDLISTが設定されていないと無視します。（オプション）
        lpClass                 As String                   'ファイルクラス名もしくはGUID。fMaskメンバにSEE_MASK_CLASSNAMEが設定されていないと無視します。（オプション）
        hkeyClass               As LongPtr                  'ファイルクラスのレジストリキーのハンドル。fMaskメンバにSEE_MASK_CLASSKEYが設定されていないと無視します。（オプション）
        dwHotKey                As Long                     '実行ファイルに関連したホットキー。fMaskメンバにSEE_MASK_HOTKEYが設定されていないと無視します。（オプション）
        hIcon                   As LongPtr                  'ファイルクラスのアイコンハンドル。fMaskメンバにSEE_MASK_ICONが設定されていないと無視します。（オプション）
        hProcess                As LongPtr                  '実行ファイルのハンドル。fMaskメンバにSEE_MASK_NOCLOSEPROCESSが設定されていないと0になります。（オプション）
    End Type
    
    '----------------------------------------------------------------------
    'ファイルのプロパティダイアログの表示やクリッカブルURLの実装などを行ないます。
    'lpExecInfo         :SHELLEXECUTEINFO構造体のポインター
    '戻り値             :失敗すると0 成功すると0以外を返します。
    Public Declare PtrSafe Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" ( _
                lpExecInfo As SHELLEXECUTEINFO) As LongPtr
    
#Else
  '32ビット版
    Public Type SHELLEXECUTEINFO
        cbSize                  As Long
        fMask                   As Long
        hwnd                    As Long
        lpVerb                  As String
        lpFile                  As String
        lpParameters            As String
        lpDirectory             As String
        nShow                   As Long
        hInstApp                As Long
        lpIDList                As Long
        lpClass                 As String
        hkeyClass               As Long
        dwHotKey                As Long
        hIcon                   As Long
        hProcess                As Long
    End Type

    Public Declare Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" ( _
                lpExecInfo As SHELLEXECUTEINFO) As Long
    
#End If
'----------------------------------------------------------------------
    '解説       :ファイルからプログラムを実行してファイルを開きます。
    'パラメータ :hWnd       フォームのハンドル
    '           :strPNAME   実行プログラム
    '           :strFNAME   開こうとするファイル
    '戻り値     :成功すればtrue、失敗すればfalse
'----------------------------------------------------------------------
Public Function FileOpen(ByVal FullPath As String) As Long
    Dim ShellInfo       As SHELLEXECUTEINFO
    Dim Res             As Long
    On Error GoTo ERROR_SHORI

    Res = 0

    'ShellExecuteEX関数を利用して、拡張子に関係付けられているプログラムから開きます。
    'SHELLEXECUTEINFO構造体のメンバーに値を入れます。
    With ShellInfo
        .cbSize = Len(ShellInfo)
        .fMask = (SEE_MASK_FLAG_NO_UI Or SEE_MASK_NOCLOSEPROCESS)
        .hwnd = 0
        .lpVerb = "OPEN" & vbNullChar
        .lpFile = FullPath & vbNullChar
        .lpParameters = vbNullChar
        .lpDirectory = vbNullChar
        .nShow = SW_SHOW
        .hInstApp = 0
        .lpIDList = 0
    End With

    'ShellExecuteEX関数を実行します。
    RES = ShellExecuteEX(ShellInfo)

OWARI:

    FileOpen = Res
    Exit Function
    
ERROR_SHORI:

    Res = 0
    Resume OWARI

End Function

MsgBoxの流用

COPY

'------------------------------------------------------------------
Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim FileDialog  As CFileDialog
    Dim strTitle      As String
    Dim intInd        As Long
    Dim strPath       As String
    Dim strFilter     As String
    
    strTitle = "ファイルの選択"
    intInd = 1
    strPath = ThisWorkBook.Path
    strFilter = "Microsoft Excelブック,*.xls?," & _
                "Microsoft Wordドキュ,*.doc?," & _
                "すべてのファイル,*.*"
            
    'オブジェクトを作成します。
    Set FileDialog = New CFileDialog
    With FileDialog
        .DialogTitle = strTitle
        .Filter = strFilter
        .FilterIndex = intInd
        .InitialDir = strPath
    End With

    If FileDialog.Show Then
        Me.TextBox1.Value = FileDialog.FileName
        Me.TextBox2.Value = FileDialog.FilePath
        Me.TextBox3.Value = FileDialog.FileBook
    End If

    Set FileDialog = Nothing

End Sub

'------------------------------------------------------------------
'クラスの「Class_Initialize」の書き方により下のように簡略できます
'------------------------------------------------------------------
Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim FileDialog  As CFileDialog

    'オブジェクトを作成します。
    Set FileDialog = New CFileDialog

    If FileDialog.Show Then
        Me.TextBox1.Value = FileDialog.FileName
        Me.TextBox2.Value = FileDialog.FilePath
        Me.TextBox3.Value = FileDialog.FileBook
    End If

    Set FileDialog = Nothing

End Sub

CFileDialog

クラスモジュールです。上のコードの中では、オブジェクト名を「CFileDialog」として使っています。

COPY

Option Explicit

'------------------------------------------------------------------
#If VBA7 And Win64 Then
  '64ビット版
    Private Declare PtrSafe Function SetCurrentDirectory Lib "Kernel32" Alias _
                            "SetCurrentDirectoryA" (ByVal CurrentDir As String) As LongPtr
#Else
  '32ビット版
    Private Declare Function SetCurrentDirectory Lib "Kernel32" Alias _
                            "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long
#End If

' -----------------------------------------------メンバー(フィールド)の定義
Private pMH_strDialogTitle    As String
Private pMH_strFileName       As String
Private pMH_strInitialDir     As String
Private pMH_strFilter         As String
Private pMH_intFilterIndex    As Integer
Private pMH_strFilePath       As String
Private pMH_strFileBook       As String

'------------------------------------------------------------------
'タイトル名のセット
Public Property Let DialogTitle(ByVal strValue As String)
    
    pMH_strDialogTitle = strValue

End Property

'------------------------------------------------------------------
'フィルターのセット
Public Property Let Filter(ByVal strValue As String)
    
    pMH_strFilter = strValue

End Property

'------------------------------------------------------------------
'フィルターインデックスのセット
Public Property Let FilterIndex(ByVal intValue As Integer)
    
    pMH_intFilterIndex = intValue

End Property

'------------------------------------------------------------------
'デフォルトのオープンフォルダー
Public Property Let InitialDir(ByVal strValue As String)
    
    pMH_strInitialDir = strValue

End Property

'------------------------------------------------------------------
'フルパスの取得
Public Property Get FileName() As String
    
    FileName = pMH_strFileName

End Property

'------------------------------------------------------------------
'パスの取得
Public Property Get FilePath() As String
    
    FilePath = pMH_strFilePath

End Property

'------------------------------------------------------------------
'拡張子付きのファイル名
Public Property Get FileBook() As String
    
    FileBook = pMH_strFileBook

End Property

'------------------------------------------------------------------
Private Sub Class_Initialize()

    pMH_strDialogTitle = "ファイルの選択"
    pMH_intFilterIndex = 1
    pMH_strInitialDir = ThisWorkbook.Path
    pMH_strFilter = "Microsoft Excelブック,*.xls?," & _
                    "Microsoft Wordドキュ,*.doc?," & _
                    "すべてのファイル,*.*"
                    
End Sub

'------------------------------------------------------------------
' 戻り値        : キャンセルが選択された場合はFalse、それ以外はTrue
'------------------------------------------------------------------
Public Function Show() As Boolean
    Dim I       As Integer
    Dim FLG     As Boolean
    Dim varBUF  As Variant
    On Error GoTo ERROR_SHORI
    
    'カレントを移動する（これがないとネットワークフォルダーに対応できない）
    SetCurrentDirectory pMH_strInitialDir & "\"
    
    'ダイヤログを開く
    varBUF = Application.GetOpenFileName(FileFilter:=pMH_strFilter, _
                                         FilterIndex:=pMH_intFilterIndex, _
                                         Title:=pMH_strDialogTitle, _
                                         MultiSelect:=False)
                                         
    '選択がなかったときエラーとする
    If varBUF = False Then
        GoTo ERROR_SHORI
    End If
                                         
    'メンバーに選択されたファイルのフルパスをセットする→プロパティで取得する
    pMH_strFileName = varBUF
    
    '最後まで続けることによって、選択されたファイルのパスとファイル名を取得する
    For I = 1 To Len(pMH_strFileName)
        If Mid(pMH_strFileName, I, 1) = "\" Then
            pMH_strFilePath = Left(pMH_strFileName, I - 1)
            pMH_strFileBook = Mid(pMH_strFileName, I + 1)
        End If
    Next I
    
    '成功したときの戻り値をセットする
    FLG = True
    
OWARI:

    Show = FLG
    Exit Function

ERROR_SHORI:

    '選択がなかった、またはエラーのときの戻り値をセットする
    FLG = False
    Resume OWARI

End Function