スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その7 


以下の様なシート「Sheet1」があったとします。
 ABCDEFGHIJKLMNOPQ
1品名            数量 納入年月 
2No1            3 2013年8月 
3No1            2 2013年9月 
4No1            5 2013年10月 
5No2            8 2013年8月 
6No2            9 2013年10月 
7No3            1 2013年9月 
8                 

で、これを俗に言うクロス集計して、シート「Sheet2」に
 ABCDE
1品名2013年8月 2013年9月 2013年10月  
2No1 
3No2  
4No3   
5     

としたい。
Excel にピボット云々があって、できるんじゃ・・・
連続した列であればできる様だけど・・・ 

考えてみたパターンは4つ
1)SUMPRODUCT を埋め込んでみる
2)過去記事「Dictionary をダンダン」を流用してみる
3) 2)の変形版(列A、P の重複排除・ソートを Excel 機能を使ってみる・・・ 2007 のみ?)
4)ADODB で接続してクロス集計とデータの転記

まぁ、1)で記述したものは以下
Public Sub test1()
  Dim iRow As Long

  Application.ScreenUpdating = False

  Worksheets.Add after:=Worksheets(Worksheets.Count)
  Worksheets("Sheet1").Range("P:P").AdvancedFilter _
    Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
  Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Copy
  Range("B1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
  Application.CutCopyMode = False

  Columns("A").ClearContents
  Worksheets("Sheet1").Range("A:A").AdvancedFilter _
    Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
  iRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
  With Range("B2", Range("A1").CurrentRegion.SpecialCells(xlCellTypeLastCell))
    .FormulaR1C1 = "=SUMPRODUCT(" _
          & "(Sheet1!R2C1:R" & iRow & "C1=RC1)" _
          & "*(Sheet1!R2C16:R" & iRow & "C16=R1C)" _
          & "*(Sheet1!R2C14:R" & iRow & "C14))"
  End With

  Range("A1").Select
  Range("A1").CurrentRegion.EntireColumn.AutoFit

  Application.ScreenUpdating = True
End Sub

 
この方法は、他と毛色が違うかな・・・ ということで、ワークシートを新規で作ってそこに・・・
Sheet1 列P を重複排除しながら、新シート A列に・・・
2行目から最後までを、B1 から横にコピー
Sheet1 列A を重複排除しながら、新シート A列に・・・
これで、行・列方向での項目部分が出来上がったので、B2 ~ 右下最後のセルまでの計算式を埋め込む・・・
SUMPRODUCT で、
・新規シートの A列その行のものが、Sheet1 のA列にあって
・新規シートの その列 1行目のものが Sheet1 のP列にあって
・Sheet1 で見つかった A列、P列が同じ行のN列のものを加算
っていう説明になるのでしょうか・・・

kEnt179  kEnt179_1

上記では、列・行の項目部分は、単に重複排除しただけなので昇順等にはなっていません。
上記サンプルレベルでは、ソコソコ良さそうですが・・・ データ量(行数)が多くなると・・・
ガー ・・・ という表現が良いのかどうか、遅くなりますね・・・

また、シート「Sheet1」のとびとびのデータ A、N、P 列を、どこかのシートにコピーして連続させて、
ピボットテーブルで・・・
これはこれで、できると思います・・・

では、以降 2)~4)をやってみたいと思います。
 
2)過去記事「Dictionary をダンダン」を流用してみる

ここでは、どんな手順で、どうやるか・・・ を説明してから
・まず、シート「Sheet1」の A列、P列を1度なめて、重複を排除します。
 この時、それぞれの列用 Dictionary のキーに値をドンドン放り込みます。
・Dictionary のキーを昇順に並べて
 ・・「納入年月」(P列)を昇順にしたキーで Dictionary ・・・ dicBase を作成します。
 ・・「品名」(A列)を昇順にしたキーで Dictionary ・・・ dic を作成しますが、
  値部分を dicBase のキーをコピーした Dictionary ・・・ wdic を登録します。
  これにより dic(A列の値)(P列の値) 記述で、数量が扱えるようになります。
  つまり、上記・・部分では、「品名」と「納入年月」の全組合せを作っていた事になります。
  「数量」部分は加算するので、dic(vA)(vP) = dic(vA)(vP) + 数量 の計算だけになります。
・上記計算式だけの処理で、もう1度全行見ます(データをなめるのは計2回)
・計算が終わったら、
 シート「Sheet2」を綺麗にしてから
 ・・B1 ~ 横方向に dicBase のキーを転記し、書式をシート「Sheet1」の P列2行目のものを適用
 ・・以降、順次 dic のキーを A列に
   数量部分は、一気に1行分 dic(vA).Items で転記
  解説?)
   dic(vA) ・・・ これにより、値として登録していた Dictionary 部分が参照できる事に
   その Dictionary は、納入年月が昇順でキーとなっているので Items で一気に得る
   (この部分は、dicBase を元にして作っているので、キーの個数は dicBase.Count を利用)

こんな感じで考えて、記述したのは以下
Private Function mySort(ByVal vAry As Variant) As Variant
  Dim v As Variant
  Dim i As Long, j As Long

  For i = LBound(vAry) To UBound(vAry) - 1
    For j = i + 1 To UBound(vAry)
      If (vAry(i) > vAry(j)) Then
        v = vAry(i)
        vAry(i) = vAry(j)
        vAry(j) = v
      End If
    Next
  Next
  mySort = vAry
End Function

Public Sub test2()
  Dim dicA As Object, dicP As Object
  Dim dicBase As Object
  Dim dic As Object, wdic As Object
  Dim iRow As Long
  Dim vA As Variant, vP As Variant

  Application.ScreenUpdating = False

  Worksheets("Sheet1").Activate
  Set dicA = CreateObject("Scripting.Dictionary")
  Set dicP = CreateObject("Scripting.Dictionary")
  For iRow = 2 To Range("A" & Rows.Count).End(xlUp).Row
    dicA(Cells(iRow, "A").Value) = Null
    dicP(Cells(iRow, "P").Value) = Null
  Next
  Set dicBase = CreateObject("Scripting.Dictionary")
  For Each vP In mySort(dicP.Keys)
    dicBase(vP) = Empty
  Next
  Set dic = CreateObject("Scripting.Dictionary")
  For Each vA In mySort(dicA.Keys)
    Set wdic = CreateObject("Scripting.Dictionary")
    For Each vP In dicBase.Keys
      wdic(vP) = Empty
    Next
    dic.Add vA, wdic
  Next

  For iRow = 2 To Range("A" & Rows.Count).End(xlUp).Row
    vA = Cells(iRow, "A").Value
    vP = Cells(iRow, "P").Value
    dic(vA)(vP) = dic(vA)(vP) + Cells(iRow, "N").Value
  Next

  Worksheets("Sheet2").Activate
  Cells.ClearContents
  iRow = 1
  Cells(iRow, "A") = "品名"
  Cells(iRow, "B").Resize(, dicBase.Count) = dicBase.Keys
  With Range(Cells(iRow, "B"), Cells(iRow, dicBase.Count + 1))
    .NumberFormat = Worksheets("Sheet1").Cells(2, "P").NumberFormat
  End With
  For Each vA In dic.Keys
    iRow = iRow + 1
    Cells(iRow, "A") = vA
    Cells(iRow, "B").Resize(, dicBase.Count) = dic(vA).Items
  Next
  
  Range("A1").CurrentRegion.EntireColumn.AutoFit

  Application.ScreenUpdating = True
End Sub

 
kEnt179_2
まぁ、ソコソコ動くんじゃないでしょうか・・・


3) 2)の変形版(列A、P の重複排除・ソートを Excel 機能を使ってみる・・・ 2007 のみ?)

ここでは、2)の変形版(列A、P の重複排除・ソートを Excel 機能を使ってみよう・・・ というもの
Sort ところの記述は、2007 になってから追加された物の様で、他バージョンでは NG かと・・・
(2000 / 2003 では、実行時エラーとなって止まります)

やっている事は、2)とほぼ変わりませんが、作業用の列として A列の前に1列挿入して・・・
作業が終わったら、その列を削除して・・・ 何もなかったように動いてみましょうか・・・
その作業用の列では、
・まず、P列を重複排除したものをおいといて、その列だけ昇順並びかえしましょう
 これが終わったら、Dictionary ・・・ dicBase を作成
・A列を重複排除したものをおいといて、その列だけ昇順並びかえしましょう
 これが終わったら、Dictionary ・・・ dic を作成・・・・この部分は 2)と同じ
で、以降、dic を使った処理は同じ・・・

後から分かった事ですが、
元のシート「Sheet1」のデータ件数(行数)が多くなればなるほど、「列の挿入」は遅くなりますね・・・
これなら、まだ、2)の方が使えるものかと・・・
Public Sub test3()
  Dim dicBase As Object
  Dim dic As Object, wdic As Object
  Dim iRow As Long, i As Long
  Dim vA As Variant, vP As Variant

  Application.ScreenUpdating = False

  Worksheets("Sheet1").Activate
  Columns("A").Insert
  Range("Q:Q").AdvancedFilter _
    Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
  With Worksheets("Sheet1").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues _
            , Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A:A")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  Set dicBase = CreateObject("Scripting.Dictionary")
  For iRow = 2 To Range("A" & Rows.Count).End(xlUp).Row
    dicBase(Range("A" & iRow).Value) = Empty
  Next

  Columns("A").ClearContents
  Range("B:B").AdvancedFilter _
    Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
  With Worksheets("Sheet1").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues _
            , Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A:A")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  Set dic = CreateObject("Scripting.Dictionary")
  For iRow = 2 To Range("A" & Rows.Count).End(xlUp).Row
    Set wdic = CreateObject("Scripting.Dictionary")
    For Each vP In dicBase.Keys
      wdic(vP) = Empty
    Next
    dic.Add Range("A" & iRow).Value, wdic
  Next
  Columns("A").Delete

  For iRow = 2 To Range("A" & Rows.Count).End(xlUp).Row
    vA = Cells(iRow, "A").Value
    vP = Cells(iRow, "P").Value
    dic(vA)(vP) = dic(vA)(vP) + Cells(iRow, "N").Value
  Next

  Worksheets("Sheet2").Activate
  Cells.ClearContents
  iRow = 1
  Cells(iRow, "A") = "品名"
  Cells(iRow, "B").Resize(, dicBase.Count) = dicBase.Keys
  With Range(Cells(iRow, "B"), Cells(iRow, dicBase.Count + 1))
    .NumberFormat = Worksheets("Sheet1").Cells(2, "P").NumberFormat
  End With
  For Each vA In dic.Keys
    iRow = iRow + 1
    Cells(iRow, "A") = vA
    Cells(iRow, "B").Resize(, dicBase.Count) = dic(vA).Items
  Next

  Range("A1").CurrentRegion.EntireColumn.AutoFit

  Application.ScreenUpdating = True
End Sub

 

じゃ・・・ じゃぁでもないですね・・・
せっかくなので、シート「Sheet1」を参照したクロス集計をやってみましょうか・・・
( CSV、Excel シート・・・ これを参照した方法のいくつかは、過去記事に何個かあったかと)

4)ADODB で接続してクロス集計とデータの転記

ここでは、Excel シートに ADODB 接続し、クロス集計結果をシートに転記しようというもの・・・
まず、考えなくてはならないのが、
・参照対象のシート「Sheet1」の1行目は、フィールド名としては使えない・・・
 なので、ヘッダなしとして、1行目もデータとして参照します。
 ヘッダなしで参照すると、
 「A列」が「F1」、「N列」が「F14」、同様に「P列」が「F16」のフィールド名になります。
 参照できるようになりますが、1行目を排除する為に「数量」列部分を利用します。
 今回の場合、WHERE IsNumeric(F14) を条件に与える事で排除できます。

以下処理でやっているのは、
・ADODB の接続に、2007 以降のもの、2003 以前のもので接続を試みます
 Excel ファイルの絶対パスは、ThisWorkbook.FullName を使用
 今回のファイルの拡張子は xls になっているので、Excel 8.0 部分はそのままで・・・
 もし、xlsm とかであれば、Excel 8.0 → Excel 12.0 Xml に変更すれば動くかと・・・
・接続できたら、
  sSql = "TRANSFORM Sum(F14) AS 値 " _
      & "SELECT F1 FROM [Sheet1$] " _
      & "WHERE IsNumeric(F14) " _
      & "GROUP BY F1 " _
      & "PIVOT F16;"
の、クロス集計の結果をレコードセットで受け取り、Excel シートへ転記

全記述は以下
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 test4()
  Dim cn As Object, rs As Object
  Dim v As Variant
  Dim sSql As String
  Dim i As Long

  Application.ScreenUpdating = False

  On Error Resume Next ' ★★ 記述抜け(追加してから確認ね)
  Set cn = CreateObject("ADODB.Connection")
  For Each v In Array(PN2007, PN2003)
    cn.Open "Provider=" & v & ";Data Source=" & ThisWorkbook.FullName _
        & ";Extended Properties='Excel 8.0;HDR=No'"
    If (cn.State = adStateOpen) Then Exit For
  Next
  If (IsEmpty(v)) Then
    MsgBox "環境不足で処理中断", vbCritical
    Set cn = Nothing
    Exit Sub ' Application.ScreenUpdating = True の処理がない(追加要)
  End If

  sSql = "TRANSFORM Sum(F14) AS 値 " _
      & "SELECT F1 FROM [Sheet1$] " _
      & "WHERE IsNumeric(F14) " _
      & "GROUP BY F1 " _
      & "PIVOT F16;"

  On Error GoTo 0 ' ★★ 記述抜け(追加してから確認ね)
  Set rs = cn.Execute(sSql)
  If (Not rs.EOF) Then
    Worksheets("Sheet2").Activate
    Cells.ClearContents
    For i = 1 To rs.fields.Count - 1
      Cells(1, i + 1) = rs(i).Name
    Next
    With Cells(1, 2).CurrentRegion
      .NumberFormat = Worksheets("Sheet1").Cells(2, "P").NumberFormat
    End With
    Cells(1, 1) = Worksheets("Sheet1").Cells(1, "A")
    Cells(2, 1).CopyFromRecordset rs
    Range("A1").CurrentRegion.EntireColumn.AutoFit
  End If
  rs.Close
  Set rs = Nothing
  Set cn = Nothing

  Application.ScreenUpdating = True
End Sub

 
※ サンプルファイルの記述では ★★ 部分が抜けてます(追記後、確認してください)

サンプルでの表示結果は、
「1)」と「2)3)4)」の2通りになります。
・「1)」では、データがない所は、0 が表示されます。
・「2)3)4)」では、データがない所は空白
 これは、Dictionary 生成時の値の初期値を Empty にしていたから・・・ かと・・・

数行のデータなら、どの方法でも大差はないですね・・・
でも、データ量(行数)が 2000 行を超えるとか・・・ いろいろと処理時間差が出てきますね・・・

今のところで速い順は、4)、そこそこ 2)、ガー ・・・ で 3)1)どっこい
【追記】9/26
処理性能の計り方に問題があったみたいで・・・
というのは、SUMPRODUCT で Sheet1 を参照するシートがあった時、
その Sheet1 に列挿入云々すると SUMPRODUCT の式部分の更新で時間がかかるみたい・・・
この影響を受けたのが 3) の方法・・・ SUMPRODUCT のシートがない状態でもやってみた。

計測1)SUMPRODUCT のシートがない状態で(提示サンプルにて)
 2)3)4)
137.6581 35.2112 72.9569 
236.4286 51.6956 88.6082 
337.1619 54.43 80.3103 
436.2966 49.499 77.9499 
538.2081 53.4502 74.5218 
平均37.1507 48.8572 78.8694 


計測2)SUMPRODUCT のシートを作ってみる(提示サンプルにて)
 1)
148.3233 
255.483 
355.3261 
435.6796 
534.5913 
平均45.8807 


計測3)SUMPRODUCT のシートがない状態で 500 品名の作成データ(2806 行のデータ)
 2)3)4)
1613.3703 412.3646 346.3265 
2563.0563 407.1477 349.8983 
3594.861 419.9903 347.1312 
4630.9738 407.4298 345.29 
5627.5789 404.562 350.1437 
平均605.9681 410.2989 347.7579 


計測4)SUMPRODUCT のシート1つの状態で 500 品名の作成データ(2806 行のデータ)
 2)3)4)
12009.028 40809.8341 428.2809 
21940.96 40753.4124 403.9093 
31940.5127 40682.6349 404.3728 
41949.7605 40449.6774 402.1703 
51939.1404 40631.9015 401.9855 
平均1955.8803 40665.4921 408.1438 

※ 関係ないと思っていた 2) 4)も遅くなった

計測5)SUMPRODUCT のシートを作ってみる( 500 品名の作成データ(2806 行のデータ))
 1)
124841.1746 
224839.2767 
324800.4721 
425030.2216 
524930.2174 
平均24888.2725 


打ち消した部分の記述は、計測4)5)から来たものでした・・・
まっ、こんな感じ・・・ でした


で、簡単に速さを確認だけする物を以下に用意しました。


大量データでの確認

以下の MkTestSheet() を実行すると、
・現状の「Sheet1」を「Sheet1A」~ に名前変更後
・「Sheet1」を作成します
 ・・品名 3 ~ 5 文字の物を 500 個
 ・・各「品名」毎に、「数量」「納入年月」データを 1 ~ 10 個

もちろん、ループ数を変更すれば、いかようにでも・・・
Private Function SheetMove(sName As String) As Boolean
  Dim i As Long

  SheetMove = False
  i = 0
  On Error GoTo ERR_HND
ERR_RESUME:
  Worksheets(sName).Name = sName & Chr(Asc("A") + i)

  On Error GoTo ERR_EXIT
  With Worksheets.Add(before:=Worksheets(1))
    .Name = sName
    .Columns("A:P").ColumnWidth = 3
  End With
  SheetMove = True
  Exit Function

ERR_HND:
  If (i < 25) Then
    i = i + 1
    Resume ERR_RESUME
  End If
ERR_EXIT:
End Function

Private Function myA() As String
  Dim sS As String
  Dim i As Long, j As Long

  sS = ""
  For i = 1 To Int(Rnd() * 3) + 3
    sS = sS & Chr(Asc("A") + Int(Rnd() * 26))
  Next
  myA = sS
End Function

Private Function myN() As Long
  myN = Int(Rnd() * 100) + 1
End Function

Private Function myP() As Date
  myP = DateAdd("m", Int(Rnd() * 36), #1/1/2010#)
End Function


Public Sub MkTestSheet()
  Dim sS As String
  Dim iRow As Long, i As Long, j As Long

  Application.ScreenUpdating = False
  If (SheetMove("Sheet1")) Then
    Randomize
    Cells(1, "A") = "品名"
    Cells(1, "N") = "数量"
    Cells(1, "P") = "納入年月"
    iRow = 2
    For i = 1 To 500
      sS = myA
      For j = 0 To Int(Rnd() * 10)
        Cells(iRow, "A") = sS
        Cells(iRow, "N") = myN
        Cells(iRow, "P") = myP
        iRow = iRow + 1
      Next
    Next
    With Range(Cells(2, "P"), Cells(Rows.Count, "P").End(xlUp))
      .NumberFormat = "yyyy\年m\月"
    End With
    Columns("A:P").EntireColumn.AutoFit
  End If
  Application.ScreenUpdating = True
End Sub

 

雰囲気、以下の様な表示に
kEnt179_3  kEnt179_4

これでやると、4)の方法が格段に速い事が分かると思います。
(列A、N、P を連続させて、ピボットテーブル・・・ これ、未確認なので・・・ 速いのかも??)


なお、Excel の関数等使う時には、こんなところに気をつければいいよ・・・ 等、教えてください。


サンプルは以下
 バージョン 2007
 ファイル kEnt179.zip
 サイズ 28,747
※ ファイルは zip 形式
※ 2007 で作成した Excel(xls) ファイル
※ 2000 / 2003 でも動作

関連記事

2013/09/22

Category: やってみる

TB: --  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △


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