FC2ブログ

スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その5 


Excel のセルに計算式をゴリゴリ入れて・・・・
でも、入力して、一段落したところでハイ計算・・・・
・・・ってなことなら、VBA(マクロ)にしておいた方が、後々楽になるのかなぁ~~
(関数をあまり理解できていない、言い訳になるかも・・・)

ということで、
kEnt142

左の表があった場合、「拠点」別に、いくらのものが計上されているか求める・・・
また、「担当者」別にまとめるものを関数化してみました。


Public Sub Sample(rng As Range, iShowCol As Long, iLookCol As Long, rrng As Range)

rng:表の左上の項目を指定 ( 図では、Range("A2") )
iShowCol:どの項目部分でまとめるかを rng との相対で (「拠点」なら 0 )
iLookCol:どの項目を拾うかを rng との相対で (「金額」なら 2 )
rrng:結果をどこから表示するかを Range で指定 (例 Range("E2") )

なお、数値部分を拾うものとして合計する部分を付加してました。
 
まずは、VBA で記述したものから

Private Function mySort(ByVal v As Variant) As Variant
  Dim i As Long, j As Long
  Dim vTmp As Variant

  On Error GoTo ERR_HND
  For i = 0 To UBound(v) - 1
    For j = i To UBound(v)
      If (v(i) > v(j)) Then
        vTmp = v(i)
        v(i) = v(j)
        v(j) = vTmp
      End If
    Next
  Next
ERR_HND:
  mySort = v
End Function

Public Sub Sample(rng As Range, iShowCol As Long, iLookCol As Long, rrng As Range)
  Dim dic As Object
  Dim i As Long, j As Long
  Dim sS As String
  Dim v As Variant, vt As Variant

  Set dic = CreateObject("Scripting.Dictionary")
  With rng
    For i = 1 To .CurrentRegion.EntireRow.Count - 1
      sS = .Offset(i, iShowCol).Value
      v = dic.Item(sS)
      If (Not IsArray(v)) Then
        ReDim v(0)
      Else
        ReDim Preserve v(UBound(v) + 1)
      End If
      v(UBound(v)) = .Offset(i, iLookCol).Value
      dic.Item(sS) = v
    Next
  End With

  If (dic.Count > 0) Then
    v = mySort(dic.Keys) ' 並び替えが不要なら v = dic.Keys に
'    v = dic.Keys
    With rrng
      For i = 0 To UBound(v)
        With .Offset(0, i)
          .Value = v(i)
          .Interior.ColorIndex = 37
          .HorizontalAlignment = xlCenter
        End With
        vt = dic.Item(v(i))
        .Offset(1, i).Resize(UBound(vt) + 1) = WorksheetFunction.Transpose(vt)
      Next
      With .CurrentRegion
        .NumberFormatLocal = "#,##0"
        j = .EntireRow.Count
      End With
      With Range(.Offset(j, 0), .Offset(j, UBound(v)))
        .FormulaR1C1 = "=SUM(R[-" & j - 1 & "]C:R[-1]C)"
        .Interior.ColorIndex = 36
        .EntireColumn.AutoFit
      End With
      .CurrentRegion.Borders.LineStyle = xlContinuous
    End With
  End If
  Set dic = Nothing
End Sub

 
指定された表の左上のところから、Offset を使ってデータを拾っていきます。
まとめる項目・・・これを Dictionary のキーとして扱っていきます。
Dictionary に登録されていなかった場合、得られた値は配列になっていません。
これを利用し、配列作って値を格納していきます。
配列だったら ReDim Preserve してドンドン格納していきます。

最終的に処理しきって、出来上がった Dictionary を使って結果を表示していきます。
キーとして扱った部分をソート(不要なら省略)して、項目として使っていきます。
そのキーでの値は配列になっているので、それを WorksheetFunction.Transpose を使って
縦に並べていきます。
表が出来上がったら、項目部分も含んでしまいますが、桁区切りの書式を設定します。
で、後は合計部分の数式を埋め込んで・・・・罫線引いて・・・終了です。

確認用の VBA(マクロ)を2つ用意

「test1」
Public Sub test1()
  With Worksheets("Sheet1")
    .Range("E2").CurrentRegion.Clear
    Call Sample(.Range("A2"), 0, 2, .Range("E2"))
    .Range("J2").CurrentRegion.Clear
    Call Sample(.Range("A2"), 1, 2, .Range("J2"))
    .Range("J14").CurrentRegion.Clear
    Call Sample(.Range("B2"), 0, 1, .Range("J14"))
  End With
End Sub

 
「拠点」についてまとめるものと
「担当者」についてまとめるもので、指定方法を変えて見たもの2つ


以下は、シート「出力」が無かったら作って・・・っていうもの
kEnt142_1

「test2」
Public Sub test2()
  Dim ws As Worksheet
  Const sN As String = "出力"

  On Error Resume Next
  Set ws = Worksheets(sN)
  If (ws Is Nothing) Then
    Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    ws.Name = sN
  End If
  ws.Range("B2").CurrentRegion.Clear
  Call Sample(Worksheets("Sheet1").Range("B2"), 0, 1, ws.Range("B2"))
  ws.Range("I2").CurrentRegion.Clear
  Call Sample(Worksheets("Sheet1").Range("A2"), 0, 2, ws.Range("I2"))
  Set ws = Nothing
End Sub

 

そうそう、セル結合していた時の書き方がある様で・・・・・
上記は対応できていないと思います。

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

2012/10/10

Category: やってみる

TB: --  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △


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