FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その6 


以下の様な質問があり、ADO を使った方法を提示してみました。

あるシステムから売上データが CSV ファイルとして出力されてくる。
項目が多すぎるので、必要な項目だけに集約、集計したい。
行数は1万行ぐらいあり、入力される担当者や製品名も数百種類ある。
CSV のヘッダには、
「日時」「ID」「担当者」「製品名」「定価」「売先」「販売」「経費」
があり、欲しい集計結果は、
「日時」「ID」「担当者」「製品名」「定価」をグループとみなした(「売先」は無視する)
「販売」「経費」の各合計 になる。

エクセルの小計で試したのですが、基準とできる列が1列しか指定できない為できなかった。

元CSVファイルと、出力結果は以下の様になります。
kEnt143

詳細は後述という事にして、追加として
・EXCEL のシートにある表(CSVと同じ)を、同様に ADO でやってみる・・・これを2通り
・EXCEL にはグループという考え方が無い?のか、関数を作ってみました。

Public Sub GrpSums(rng1 As Range, rng2 As Range, rng3 As Range)

rng1:グループとしてみなす項目を指定
rng2:合計する項目を指定
rng3:結果を表示するところを指定

使用例)

Call GrpSums(Range("B3:F3"), Range("H3:I3"), Range("B20"))  とか
Call GrpSums(Range("B3,C3,E3,F3,H3"), Range("J3,L3"), Range("B20"))  とかとか
 
まず、回答した一部を紹介します。

CSVファイルを直接見て、集計してしまいます。
ファイル名を「test.csv」
ファイルを置いたフォルダを「E:\Excel\qa」と仮定します。

以下を記述して実行すると、添付図の様になります。
(Vista + Office 2007 での結果)

Public Sub Sample()
  Dim cn As Object, rs As Object
  Dim sSql As String
  Dim i As Integer
  Const sPath As String = "E:\Excel\qa" ' CSV ファイルのパス
  Const sCsv As String = "test.csv" ' CSV ファイル名

  Set cn = CreateObject("ADODB.Connection")
  cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPath & ";" _
      & "Extended Properties='text;HDR=Yes;FMT=Delimited'"

  sSql = "SELECT 日時, ID, 担当者, 製品名, 定価," _
      & " Sum(販売) AS 販売計, Sum(経費) AS 経費計" _
      & " FROM [" & sCsv & "] GROUP BY 日時, ID, 担当者, 製品名, 定価;"
  Set rs = cn.Execute(sSql)
  With Range("A1")
    For i = 0 To rs.fields.Count - 1
      .Offset(, i) = rs.fields(i).Name
    Next
    .Offset(1).CopyFromRecordset rs
  End With
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub


どこに結果を貼り付けるかは With Range("A1") を変更するだけです。

※ 私の環境には ACCESS がインストールされているのでエラーにはなりませんが、
Microsoft.ACE.OLEDB.12.0 がどうたら・・・エラーが出た場合は、以下を読んでみてください。

「Microsoft.ACE.OLEDB.12.0 プロバイダは、ローカルコンピュータに登録されていません」 というメッセージが表示される
http://social.msdn.microsoft.com/Forums/ja/vbgeneralja/thread/573f33c6-ca85-448e-ae35-247d24642a89

Microsoft Access データベース エンジン 2010 再頒布可能コンポーネント
http://www.microsoft.com/ja-jp/download/details.aspx?id=13255


また、環境によっては、
Microsoft.ACE.OLEDB.12.0 を Microsoft.Jet.OLEDB.4.0 に変更してうまくいくかも

なお、上記で扱える項目数の上限は250個位までだったと思います。
(CSVファイル内の項目数になります)

・・・・・・・・
・・・・・・

実際、ACCESS がインストールされていない PC は私の周りに無いので、どうなるのかわかりません。
なので、これから記述する ADO を使った物は、環境によってはエラーになるかもしれません。
一応、2000 / 2003 / 2007 環境で動作確認できてますので、そいうものか・・・と思って頂ければと

サンプル用に作り直したのが以下になります。
(CSV ファイルは「test.csv」名で、Excel ファイルと同じフォルダにあるものとしています)
kEnt143
Private Const adStateOpen = 1
Private Const PN2007 As String = "Microsoft.ACE.OLEDB.12.0"
Private Const PN2003 As String = "Microsoft.Jet.OLEDB.4.0"


Public Sub Sample_CSV()
  Dim cn As Object, rs As Object
  Dim sSql As String
  Dim i As Integer
  Dim v As Variant
  Dim sS As String
  Dim sPath As String ' CSV ファイルのパス
  Const sCsv As String = "test.csv" ' CSV ファイル名

  On Error Resume Next
  sS = ThisWorkbook.FullName
  sPath = Left(sS, InStrRev(sS, "\") - 1)
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='text;HDR=Yes;FMT=Delimited'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT 日時, ID, 担当者, 製品名, 定価," _
      & " Sum(販売) AS 販売計, Sum(経費) AS 経費計" _
      & " FROM [" & sCsv & "] GROUP BY 日時, ID, 担当者, 製品名, 定価;"
  Set rs = cn.Execute(sSql)
  With Worksheets("Sheet1")
    .Activate
    With .Range("A1")
      .Select
      .CurrentRegion.ClearContents
      For i = 0 To rs.fields.Count - 1
        .Offset(, i) = rs.fields(i).Name
      Next
      .Offset(1).CopyFromRecordset rs
    End With
  End With
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub

 
Provider 指定用の文字列を2つ用意しておいて、繋がればそれを使って・・・・
ま、後は、引数で CSV ファイルパスを渡すように変更して使いまわしできるようにするとか・・・・

で、以下は CSV ファイルは既にシートに読み込んでいた。それを対象にしましょう。
kEnt143_1
シート「TBL」には通常 ACCESS と EXCEL でやり取りする際の配置になっています。
( "A1" )起点。  なお、EXCEL ファイルの拡張子は「xls」にしていました。
Public Sub Sample_TBL()
  Dim cn As Object, rs As Object
  Dim sSql As String
  Dim i As Integer
  Dim v As Variant
  Dim sPath As String ' Excel ファイルのパス
  Const sSht As String = "TBL$" ' シート名 + $

  On Error Resume Next
  sPath = ThisWorkbook.FullName
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='Excel 8.0;HDR=Yes'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT 日時, ID, 担当者, 製品名, 定価," _
      & " Sum(販売) AS 販売計, Sum(経費) AS 経費計" _
      & " FROM [" & sSht & "] GROUP BY 日時, ID, 担当者, 製品名, 定価;"
  Set rs = cn.Execute(sSql)
  With Worksheets("Sheet1")
    .Activate
    With .Range("A10")
      .Select
      .CurrentRegion.ClearContents
      For i = 0 To rs.fields.Count - 1
        .Offset(, i) = rs.fields(i).Name
      Next
      .Offset(1).CopyFromRecordset rs
    End With
  End With
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub

上記の黄色い部分が CSV と異なる部分になります。
大きくは、CSV で指定する sPath 部分は、CSV ファイルのあるフォルダになります。

kEnt143_2
EXCEL のシートを対象にするのは変わりませんが、
シート「TBL」の様に( "A1" )を起点にしていない表を処理するのが以下。
Public Sub Sample_TBL2()
  Dim cn As Object, rs As Object
  Dim sSql As String
  Dim i As Integer
  Dim v As Variant
  Dim sPath As String ' Excel ファイルのパス
  Const sSht As String = "TBL2$B3:I15" ' シート名 + $ + 範囲

  On Error Resume Next
  sPath = ThisWorkbook.FullName
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & sPath & ";" _
        & "Extended Properties='Excel 8.0;HDR=Yes'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub
  End If

  sSql = "SELECT 日時, ID, 担当者, 製品名, 定価," _
      & " Sum(販売) AS 販売計, Sum(経費) AS 経費計" _
      & " FROM [" & sSht & "] GROUP BY 日時, ID, 担当者, 製品名, 定価;"
  Set rs = cn.Execute(sSql)
  With Worksheets("Sheet1")
    .Activate
    With .Range("A20")
      .Select
      .CurrentRegion.ClearContents
      For i = 0 To rs.fields.Count - 1
        .Offset(, i) = rs.fields(i).Name
      Next
      .Offset(1).CopyFromRecordset rs
    End With
  End With
  rs.Close: Set rs = Nothing
  cn.Close: Set cn = Nothing
End Sub

( "A1" )起点から変更した部分は、黄色の部分になります。

    With .Range("A20")
部分は結果を出力する先を変えているだけなので、シート内の範囲を指定する部分の変更だけですね。

それぞれ実行してみた結果は、シート「Sheet1」に出力されます。
kEnt143_3
確認は、マクロの実行から行います。
"A1" からの表示は、CSV ファイルを対象とした時のもの
"A10"からの表示は、シート「TBL」を対象とした時のもの
"A20"からの表示は、シート「TBL2」を対象とした時のもの

同じデータをもとにしているので、結果は同じですね


さて、ここからが本題というか・・・・
グループを考えた合計をする関数を作ってみたので、まずは、その記述から
(セル結合した表は考えていませんので・・・・)
Public Sub GrpSums(rng1 As Range, rng2 As Range, rng3 As Range)
  Dim dic As Object
  Dim r As Range
  Dim sS As String
  Dim v As Variant
  Dim iLoop As Long
  Dim i As Long, j As Long
  Const sDLM As String = "__"

  iLoop = rng1.CurrentRegion.Rows.Count - 1
  If (iLoop < 1) Then Exit Sub
  If (rng3.Count <> 1) Then Exit Sub

  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To iLoop
    sS = ""
    For Each r In rng1.Offset(i)
      sS = sS & sDLM & r
    Next
    v = dic.Item(sS)
    If (Not IsArray(v)) Then ReDim v(rng2.Count + 1)
    j = 0
    For Each r In rng2.Offset(i)
      v(j) = v(j) + r
      j = j + 1
    Next
    v(j) = v(j) + 1 ' 出現個数(後々使えるかも)
    v(j + 1) = i  ' 見出しからの相対行(結果を表示する際のコピー元)
    dic.Item(sS) = v
  Next

  With rng3
    rng1.Copy .Offset(0, 0)
    i = rng1.Count
    For Each r In rng2
      .Offset(, i) = r & "計"
      i = i + 1
    Next
    i = 1
    For Each v In dic.items
      j = v(rng2.Count + 1)
      rng1.Offset(j).Copy .Offset(i)
      .Offset(i, rng1.Count).Resize(, rng2.Count) = v
      i = i + 1
    Next
  End With
  Set dic = Nothing
End Sub

 
まず、rng1、rng2 で指定する項目の行は、同じでなくてはなりません。
rng1 で指定された CurrentRegion の範囲で Offset を用いてグループ、合計を処理していきます。
グループを管理する方法として、
・全項目を1つの文字列にして、同じ文字列になったものをグループとして扱いましょう。
・この同じ・・・ Dictionary のキーとしてまとめていきましょう。
・合計値は、Dictionary のItem として、配列で加算していきましょう。
 そして、Item の配列内に、グループとして何個扱ったか、
 また、元々の値は何行目を参照したか覚えておいて、結果出力時にコピー元にしちゃいましょう。

例えば、合計する項目が2つあったら、Item は配列 0 ~ 3 のものになります。
0、1 は、値をドンドン加算していくもの。
2 は、何個グループとして扱ったか(いわゆる、カウント)
3 は、結果を表示する際に参照するグループとして扱った最終行( Offset 値 )

同一グループか、項目を1つの文字列にすると言っていましたが、結果を表示する際、
1つの文字列から逆展開して項目値を求め直した場合、
数値部分を数値 or 文字 のどちらだったのか、判別展開する手段がありませんでした。
それゆえ、グループとして扱った最終行( Offset 行)を記憶しておいて、
結果を表示する際に、その行からコピーする方法としました。

で、合計する項目部分には "計" を付加した項目名に作り直して、加算していた値を展開・・・

シート「TBL2」に対して確認できるマクロは「TBL2_x」( x は数字 )で用意しました。
kEnt143_4
Public Sub TBL2_1()
  With Worksheets("TBL2")
    .Activate
    With .Range("B20")
      .Select
      .CurrentRegion.ClearContents
    End With
    Call GrpSums(.Range("B3:F3"), .Range("H3:I3"), .Range("B20"))
  End With
End Sub

Public Sub TBL2_2()
  With Worksheets("TBL2")
    .Activate
    With .Range("B20")
      .Select
      .CurrentRegion.ClearContents
    End With
    Call GrpSums(.Range("C3:F3"), .Range("H3:I3"), .Range("B20"))
  End With
End Sub

Public Sub TBL2_3()
  With Worksheets("TBL2")
    .Activate
    With .Range("B20")
      .Select
      .CurrentRegion.ClearContents
    End With
    Call GrpSums(.Range("D3:F3"), .Range("H3:I3"), .Range("B20"))
  End With
End Sub

Public Sub TBL2_4()
  With Worksheets("TBL2")
    .Activate
    With .Range("B20")
      .Select
      .CurrentRegion.ClearContents
    End With
    Call GrpSums(.Range("E3:F3"), .Range("H3:I3"), .Range("B20"))
  End With
End Sub

どの部分をグループとして扱うかが異なるだけです。

また、シート「TBL3」の様に、各項目が散らばっていた場合の確認マクロ「TBL3_x」を用意しました。
kEnt143_5
Public Sub TBL3_1()
  With Worksheets("TBL3")
    .Activate
    With .Range("B20")
      .Select
      .CurrentRegion.ClearContents
    End With
    Call GrpSums(.Range("B3,C3,E3,F3,H3"), .Range("J3,L3"), .Range("B20"))
  End With
End Sub

Public Sub TBL3_2()
  With Worksheets("TBL3")
    .Activate
    With .Range("B20")
      .Select
      .CurrentRegion.ClearContents
    End With
    Call GrpSums(.Range("C3,E3,F3,H3"), .Range("J3,L3"), .Range("B20"))
  End With
End Sub

Public Sub TBL3_3()
  With Worksheets("TBL3")
    .Activate
    With .Range("B20")
      .Select
      .CurrentRegion.ClearContents
    End With
    Call GrpSums(.Range("E3,F3,H3"), .Range("J3,L3"), .Range("B20"))
  End With
End Sub

Public Sub TBL3_4()
  With Worksheets("TBL3")
    .Activate
    With .Range("B20")
      .Select
      .CurrentRegion.ClearContents
    End With
    Call GrpSums(.Range("F3,H3"), .Range("J3,L3"), .Range("B20"))
  End With
End Sub

Public Sub TBL3_5()
  With Worksheets("TBL3")
    .Activate
    With .Range("B20")
      .Select
      .CurrentRegion.ClearContents
    End With
    Call GrpSums(.Range("I3"), .Range("J3,L3"), .Range("B20"))
  End With
End Sub


いろいろと設定を変えながら、動作を確認してみてください。


今回の zip ファイルには、
・本体 EXCEL ファイル kEnt143.xls
・確認時に必要な CSV ファイル test.csv
の2つが入っています。

この2つを同一フォルダに解凍後、確認してみてください。

サンプルは以下
 バージョン 2007
 ファイル kEnt143.zip
 サイズ 25,514
※ ファイルは zip 形式
※ 2007 で作成した Excel(xls) ファイル
※ 2000 / 2003 でも動作
関連記事

2012/10/14

Category: サンプルかな

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。