EXCELとACCESSを使った運用 Part.2

2018年9月21日2018年10月4日

EXCELとACCESSを使った運用 Part.1からの続きです。

EXCELとACCESSを使って、出来ること。EXCELからACCESSにデータを追加してみようかな？日々データー量が増加して、EXCELが重くなるなんてありませんか？100万件以内ならそれでも...と思いますが、それを超えだすと厳しくなってきます。Excelは1シートに100万件までです。※2003以前はもっと少ないです。解決策はいろいろあると思うのですが、今回、Accessにデータを溜めておき、必要なときに抽出して使う方法を簡単に説明したいと思います。細かいところは、ググれば先人たちの説明がネットにあふれていますのでそちらを...（＾＾）イメ...

www.bookservice.jp

https://www.bookservice.jp/2018/09/11/2004

今回はACCESSに入っているデータを、EXCELに抽出します。

SAMPLE101.ZIP

ざっくり説明します。
Accessはデータベース管理システムのソフトウェアです。容量等に制限があり、あまり大きなデータは向きません。
一件のデータの大きさにもよりますが、数百万件程度ぐらいなら大丈夫だと思います。
以下の例は、AccessへSQLを使用して、EXCEL側へ対象日付のデータを抽出するEXCELマクロです。
そのまま抽出と、集計して抽出するマクロを掲載しています。

SQLってなんぞな？って方もいらっしゃいますよね。
今回の例題はそれほど難しいものではありません。SQLになじみのない方は、access側で、クエリを作成して、作成したデザインをSQLビューで見ると、SQL文が見えます。
※EXCEL側と少し書き方が違うところがありますので、そこはググってください。

日付指示がない場合は、クエリを作っておいて、マクロを使わないでそのまま抽出することも可能です。
・データー/ACCESSデーターベースをクリック
・対象ACCESSDBを選択…
今回はここまで。

そのまま抽出

    If IsDate(NEW_SDATE) = False Then
       MsgBox ("スタート日付を正しく入力してください"), vbCritical
       Exit Sub
    End If

    If IsDate(NEW_EDATE) = False Then
       MsgBox ("エンド日付を正しく入力してください"), vbCritical
       Exit Sub
    End If
   
    If NEW_SDATE > NEW_EDATE Then
       MsgBox ("日付の範囲がおかしいです"), vbCritical
       Exit Sub
    End If
  
    MSG_FLG = MsgBox("accessDB取込( " & NEW_SDATE & " ～ " & NEW_EDATE & " )実行OK?", vbYesNo)
    If MSG_FLG = vbNo Then
       Exit Sub
    End If

'@@@@@@@@ 対象　ACCESS OPEN @@@@@@@@@

    Const cnsTITLE = "○access抽出（*.mdb）処理"
    Const cnsFILTER = "新コレクトから (*.accdb),*.accdb"
    
    With CreateObject("WScript.Shell")
        .CurrentDirectory = Worksheets("KANRI").Range("B1") '@@ シート設定
    End With
    vFILENAME = Application.GetOpenFilename(FileFilter:=cnsFILTER, Title:=cnsTITLE)
    If VarType(vFILENAME) = vbBoolean Then
       MsgBox ("キャンセル")
       Exit Sub
    End If
  
    dbFile = vFILENAME
    myCon.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & dbFile & ""
    myCon.Open
  

    mySQL = "SELECT DATA.顧客コード, DATA.顧客名, DATA.出荷日, DATA.商品コード, DATA.商品名, DATA.金額, DATA.冊数 AS [冊数 の 合計] FROM data "
    mySQL = mySQL & "WHERE (DATA.出荷日 >= " & " #" & NEW_SDATE.Text & "# And DATA.出荷日" & " <= #" & NEW_EDATE.Text & "#) "

  
'###### SQL 保存 ######
    Worksheets("KANRI").Range("B21") = mySQL
  
'###### SQL 発行 ######
    myRecordSet.Open mySQL, myCon, adOpenDynamic
  
'###### excelへ展開 ######
    mySheetName = "PICUP1"

'※※※※※※オートフィルター解除   ※※※※※※
    If Sheets(mySheetName).AutoFilterMode Then
       Sheets(mySheetName).Range("A1").AutoFilter
    End If

'###クリア処理 ###
    Sheets(mySheetName).Select
    Cells.Select
    Selection.ClearContents

'### ヘダー作成 ###
    With Worksheets(mySheetName)
      .Cells(1, 1).Value = "顧客コード"
      .Cells(1, 2).Value = "顧客名"
      .Cells(1, 3).Value = "出荷日"
      .Cells(1, 4).Value = "商品コード"
      .Cells(1, 5).Value = "商品名"
      .Cells(1, 6).Value = "金額"
      .Cells(1, 7).Value = "冊数"
    End With
  
  
'### 明細作成 ###
    ILONG = 2
    Do Until myRecordSet.EOF
       With Worksheets(mySheetName)
         .Cells(ILONG, 1).Value = myRecordSet(0)
         .Cells(ILONG, 2).Value = myRecordSet(1)
         .Cells(ILONG, 3).Value = myRecordSet(2)
         .Cells(ILONG, 4).Value = myRecordSet(3)
         .Cells(ILONG, 5).Value = myRecordSet(4)
         .Cells(ILONG, 6).Value = myRecordSet(5)
         .Cells(ILONG, 7).Value = myRecordSet(6)
       End With
       ILONG = ILONG + 1
       myRecordSet.MoveNext
    Loop
  
'### CLOSE ###
  myRecordSet.Close
  Set myRecordSet = Nothing
  
  myCon.Close
  Set myCon = Nothing

  Range("A1").Select
  MsgBox (" 抽出終了 ")
  Application.StatusBar = " AccessDB抽出ＥＮＤ "

End Sub

集計して抽出

    If IsDate(NEW_SDATE) = False Then
       MsgBox ("スタート日付を正しく入力してください"), vbCritical
       Exit Sub
    End If

    If IsDate(NEW_EDATE) = False Then
       MsgBox ("エンド日付を正しく入力してください"), vbCritical
       Exit Sub
    End If
   
    If NEW_SDATE > NEW_EDATE Then
       MsgBox ("日付の範囲がおかしいです"), vbCritical
       Exit Sub
    End If
  
    MSG_FLG = MsgBox("accessDB取込( " & NEW_SDATE & " ～ " & NEW_EDATE & " )実行OK?", vbYesNo)
    If MSG_FLG = vbNo Then
       Exit Sub
    End If

'@@@@@@@@ 対象　ACCESS OPEN @@@@@@@@@

    Const cnsTITLE = "○access抽出（*.mdb）処理"
    Const cnsFILTER = "新コレクトから (*.accdb),*.accdb"
    
    With CreateObject("WScript.Shell")
        .CurrentDirectory = Worksheets("KANRI").Range("B1") '@@ シート設定
    End With
    vFILENAME = Application.GetOpenFilename(FileFilter:=cnsFILTER, Title:=cnsTITLE)
    If VarType(vFILENAME) = vbBoolean Then
       MsgBox ("キャンセル")
       Exit Sub
    End If
  
    dbFile = vFILENAME
    myCon.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & dbFile & ""
    myCon.Open
  

    mySQL = "SELECT DATA.顧客コード, DATA.顧客名, DATA.出荷日, Sum(DATA.金額) AS 金額の合計, Sum(DATA.冊数) AS 冊数の合計 FROM data "
    mySQL = mySQL & "WHERE (DATA.出荷日 >= " & " #" & NEW_SDATE.Text & "# And DATA.出荷日" & " <= #" & NEW_EDATE.Text & "#) "
    mySQL = mySQL & "GROUP BY DATA.顧客コード, DATA.顧客名, DATA.出荷日;"

'###### SQL 保存 ######
    Worksheets("KANRI").Range("B22") = mySQL
  
'###### SQL 発行 ######
    myRecordSet.Open mySQL, myCon, adOpenDynamic
  
'###### excelへ展開 ######
    mySheetName = "PICUP2"

'※※※※※※オートフィルター解除   ※※※※※※
    If Sheets(mySheetName).AutoFilterMode Then
       Sheets(mySheetName).Range("A1").AutoFilter
    End If

'###クリア処理 ###
    Sheets(mySheetName).Select
    Cells.Select
    Selection.ClearContents

'### ヘダー作成 ###
    With Worksheets(mySheetName)
       .Cells(1, 1).Value = "顧客コード"
       .Cells(1, 2).Value = "顧客名"
       .Cells(1, 3).Value = "出荷日"
       .Cells(1, 4).Value = "金額の合計"
       .Cells(1, 5).Value = "冊数の合計"
    End With
  
'### 明細作成 ###
    ILONG = 2
    Do Until myRecordSet.EOF
       With Worksheets(mySheetName)
         .Cells(ILONG, 1).Value = myRecordSet(0)
         .Cells(ILONG, 2).Value = myRecordSet(1)
         .Cells(ILONG, 3).Value = myRecordSet(2)
         .Cells(ILONG, 4).Value = myRecordSet(3)
         .Cells(ILONG, 5).Value = myRecordSet(4)
       End With
       ILONG = ILONG + 1
       myRecordSet.MoveNext
    Loop
  
'### CLOSE ###
  myRecordSet.Close
  Set myRecordSet = Nothing
  
  myCon.Close
  Set myCon = Nothing

  Range("A1").Select
  MsgBox (" 抽出終了 ")
  Application.StatusBar = " AccessDB抽出ＥＮＤ "

End Sub

VBA（マクロ）,その他（Microsoft）,SAMPLE付,ACCESS（all）

Posted by master

最近EXCELが重い、開くのに時間がかかる、理由が分からない。

EXCEL超初心者マクロ（7）－検索（FIND）－

コメント一覧

まだ、コメントがありません

コメントする