Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


4199 / 13646 ツリー ←次へ | 前へ→

【57874】データ集計の方法 MIRURU 08/9/18(木) 16:06 質問[未読]
【57876】Re:データ集計の方法 kanabun 08/9/18(木) 16:52 発言[未読]
【57878】Re:データ集計の方法 Hirofumi 08/9/18(木) 20:08 回答[未読]
【57880】Re:データ集計の方法 kanabun 08/9/18(木) 21:47 発言[未読]
【57881】Re:データ集計の方法 kanabun 08/9/18(木) 21:59 発言[未読]
【57937】Re:データ集計の方法 MIRURU 08/9/22(月) 11:30 お礼[未読]

【57874】データ集計の方法
質問  MIRURU  - 08/9/18(木) 16:06 -

引用なし
パスワード
   VBA初心者です。
何度、考えてもどうしても分からないので投稿させていただきました。
下記のような表があります。
シート名「data」の、項目の「NAME,BUDHO,CODE,TYPE」の4つが同じデータなら、項目「TIME」を合計して、シート名「data編集」に一行にまとめて、転記していく表を作成したいと考えております。

シート名「data」
DATE  | NAME | BUSHO | CODE | TYPE | TIME
-----------------------------------------------
08/08/01|tanaka |Seizou | A  | 1  | 2
08/08/01|yamada |Kensa | A  | 2  | 1
08/08/01|tanaka |Seizou | B  | 1  | 1
08/08/01|tanaka |Seizou | A  | 1  | 1
08/08/01|yamada |Kensa | A  | 2  | 2

↓処理後・・・
シート名「data編集」
DATE  | NAME | BUSHO | CODE | TYPE | TIME
-----------------------------------------------
08/08/01|tanaka |Seizou | A  | 1  | 3
08/08/01|yamada |Kensa | A  | 2  | 3
08/08/01|tanaka |Seizou | B  | 1  | 1

下記のようなコードを作成してみました。
Sub data編集()

Dim MaxR As Integer
Dim LastR As Integer
Dim Mydate As Date
Dim Name As Variant
Dim Busho As Variant
Dim Code As Variant
Dim Type As Variant
Dim MyTime As Variant
Dim WName As Range
Dim WBusho As Range
Dim WCode As Range
Dim WType As Range
Dim MyR As Integer


Worksheets("data").Select
MaxR = Range("A65536").End(xlUp).Row - 1

For i = 1 To MaxR
Mydate = Cells(i + 1, 1).Value
Name = Cells(i + 1, 2).Value
Busho = Cells(i + 1, 3).Value
Code = Cells(i + 1, 4).Value
Type = Cells(i + 1, 5).Value
Kousu = Cells(i + 1, 6).Value

Worksheets("data編集").Activate
LastR = Range("A65536").End(xlUp).Row

'Find検索は必要ない??ですか?

Set WName = Range(Cells(2, 2), Cells(LastR, 2)).Find(what:=Name, lookat:=xlWhole)
Set WBusho = Range(Cells(2, 3), Cells(LastR, 3)).Find(what:=Busho, lookat:=xlWhole)
Set WCode = Range(Cells(2, 4), Cells(LastR, 4)).Find(what:=Code, lookat:=xlWhole)
Set WType = Range(Cells(2, 5), Cells(LastR, 5)).Find(what:=Type, lookat:=xlWhole)

For q = 1 To LastR - 1

If Range("B" & q + 1).Value = Name And Range("C" & q + 1).Value = Busho And Range("D" & q + 1).Value = Code And Range("E" & q + 1).Value = Type Then

Range("B" & q + 1).Select
MyR = ActiveCell.Select
Range("B" & q + 1).Offset(0, 4).Value = Kousu + Range("B" & q + 1).Offset(0, 4).Value

Worksheets("data").Select
Exit For

End If

Next q
'この辺から、どう処理するコードを書けばよいのか…わからなくなってしまいました。
’↓
'重複しているデータがあれば、「Time」を合計して、一行にまとめ、なければ、最終行にデータを転記していく…という方法を知りたいです。

Worksheets("data編集").Select

Cells(LastR + 1, 1).Value = Mydate
Cells(LastR + 1, 2).Value = Name
Cells(LastR + 1, 3).Value = Busho
Cells(LastR + 1, 4).Value = Code
Cells(LastR + 1, 5).Value = Type
Cells(LastR + 1, 6).Value = Kousu

Worksheets("data").Select
Next i

End Sub
'--------------------------------------------------------
煮詰まってしまっている私です。
どうか…よろしくお願いします

 

【57876】Re:データ集計の方法
発言  kanabun  - 08/9/18(木) 16:52 -

引用なし
パスワード
   ▼MIRURU さん:

おじゃまします。

VBA だと、こういう統合問題はDictionaryオブジェクトを
使うと思いますけど、

Office TANAKA - Excel VBA(重複しないリストを作る)
h t t p://officetanaka.net/excel/vba/tips/tips80.htm


考え方として、
「NAME,BUDHO,CODE,TYPE」を一つにまとめた(結合した)列と集計列
を考えます。

| NAME + BUSHO+ CODE +TYPE  | TIME
---------------------------------------
|tanaka_Seizou_A_1      | 2
|yamada_Kensa_A_2       | 1
|tanaka_Seizou_B_1       | 1
|tanaka_Seizou_A_1      | 1     
|yamada_Kensa_A_2       | 2

説明のために、もっと簡単に
うえの URL のサンプルを利用して概略を説明すると、

名前     数量
--------- --------
田中      2
鈴木      1
山田      1
鈴木      1
山田      2
田中      2

重複しない「名前」のリストを作るなら
dic("田中") = Empty
dic("鈴木") = Empty
dic("山田") = Empty
dic("鈴木") = Empty
dic("山田") = Empty
dic("田中") = Empty
    ↑    ↑
    Key   Item

Dictionaryの key に 空のItem をどんどん追加していきます。
このとき、4番目以降の key はすでにDictionaryのキーにありますから、
同じ位置にkeyを登録するという処理がなされ、結果として重複しない
キーリスト {"田中", "鈴木", "山田"}という3つのキーがリストとして
得られることになります。

集計は Item に Empty を登録する代わりに、集計したい「数量」を
入れて登録操作をしていけばいいわけです。
dic("田中") = dic("田中") + 2
dic("鈴木") = dic("鈴木") + 1
dic("山田") = dic("山田") + 1
dic("鈴木") = dic("鈴木") + 1
dic("山田") = dic("山田") + 2
dic("田中") = dic("田中") + 2

とすると、
結果として
   Key   Item
dic("田中") = 4
dic("鈴木") = 2
dic("山田") = 3

という3つのキーと対応する数量の合計のアイテムが得られます。
結果を出力するには、
出力したい先頭セル.Resize(dic.Count, 2).Value =
  Application.Transpose(Array(dic.Keys, dic.Items))
として一括出力できます。

とまぁ、こんな感じでニュアンスのご紹介だけ(^^

【57878】Re:データ集計の方法
回答  Hirofumi  - 08/9/18(木) 20:08 -

引用なし
パスワード
   こんな手順で出来ると思います

1、Sheets("data")を、「NAME」昇順、「BUDHO」昇順、「CODE」昇順、「TYPE」昇順で整列
2、DataListの先頭行を取り出す
3、DataListの2行目を取り出す
4、1行目と2行目の「NAME,BUDHO,CODE,TYPE」を其々比較する
5、もし、1項目でも違うなら、1行目をSheets("data編集")へ出力
6、3行目を取り出し、2行目と3行目の比較を行う
7、項目全てが同じなら、2行目の「TIME」に3行目の「TIME」を加算
8、4行目を取り出し、2行目と比較、1項目でも違うなら、2行目をSheets("data編集")へ出力
9、此れを最終行の下まで行う(最終行の下の行をダミーデータとして使う)

Option Explicit
Option Compare Text

Public Sub Sample()

  '◆DataListのデータ列数(A列〜F列)
  Const clngColumns As Long = 6
  
  Dim i As Long
  Dim j As Long
  Dim lngRow As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntData As Variant
  Dim strProm As String

  '◆DataListの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("data").Cells(1, "A")

  '◆出力Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngResult = Worksheets("data編集").Cells(1, "A")

  '画面更新を停止
'  Application.ScreenUpdating = False
  
  '"data編集"に就いて
  With rngResult
    '行数の取得(行末位置取得)
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    '結果を消去
    If lngRows >= 1 Then
      .Offset(1).Resize(lngRows, clngColumns).ClearContents
    End If
  End With
  
  '"data"に就いて
  With rngList
    '行数の取得(行末位置取得)
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを「TYPE」昇順で整列
    .Offset(1).Resize(lngRows, clngColumns).Sort _
        Key1:=.Offset(1, 4), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlStroke
    'データを「NAME」昇順、「BUDHO」昇順、「CODE」昇順で整列
    .Offset(1).Resize(lngRows, clngColumns).Sort _
        Key1:=.Offset(1, 1), Order1:=xlAscending, _
        Key2:=.Offset(1, 2), Order2:=xlAscending, _
        Key3:=.Offset(1, 3), Order3:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlStroke
  End With
  
  '先頭行を配列に取得
  vntResult = rngList.Offset(1).Resize(, clngColumns).Value
  '2行目以降最終行+1まで繰り返し
  For i = 2 To lngRows + 1
    '1行分データを取得
    vntData = rngList.Offset(i).Resize(, clngColumns).Value
    '前の行と「NAME,BUDHO,CODE,TYPE」を比較
    For j = 2 To 5
      '内容が違うならForを抜ける
      If vntResult(1, j) <> vntData(1, j) Then
        Exit For
      End If
    Next j
    '内容が違う場合
    If j <= 5 Then
      '集計用配列(前の行データ)を"data編集"に出力
      lngRow = lngRow + 1
      rngResult.Offset(lngRow).Resize(, clngColumns).Value = vntResult
      '集計用配列に現在データを代入
      vntResult = vntData
    Else
      '集計用配列の「TIME」の列に現在行の「TIME」の列を加算
      vntResult(1, 6) = vntResult(1, 6) + vntData(1, 6)
    End If
  Next i
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

【57880】Re:データ集計の方法
発言  kanabun  - 08/9/18(木) 21:47 -

引用なし
パスワード
   ▼MIRURU さん:

参考まで、Dictionaryを使ったサンプルです。
ちょっと工夫したのは
「NAME + BUSHO + CODE + TYPE」 を連結してキー文字列を作り出す方法です。
上の4列をCopyすると、クリップボードに Tab区切りのテキストとして格納さ
れますから、これをDataObject経由で取得し、各行のKeyとして 使っています

Sub Try1()
 Dim rv()
 Dim r As Range
 Dim dKeys, hdr, vv
 Dim i&, j&, k&, kk&
 Dim ss$
 Dim dic As Object
 Const CLSID_DataObject = "1C3B4210-F441-11CE-B9EA-00AA006B1A69"
 
 Set dic = CreateObject("Scripting.Dictionary")
 With Worksheets("data")
   Set r = .Range(.[A2], .[A65536].End(xlUp)) 'A列データ範囲
   ReDim rv(1 To 6, r.Rows.Count)
   hdr = .[A1].Resize(, 6).Value
   For j = 1 To 6
     rv(j, 0) = hdr(1, j)
   Next
 End With
 vv = r.Resize(, 6).Value
 r.Offset(, 1).Resize(, 4).Copy   '「NAME BUSHO CODE TYPE」列を
 With GetObject("new:" & CLSID_DataObject)  'クリップボードへ送り
   .GetFromClipboard
   dKeys = Split(.GetText(1), vbCrLf)    '結合文字列を作成
   Application.CutCopyMode = True
 End With
 For i = 1 To UBound(vv)
   ss = dKeys(i - 1)
   If dic.Exists(ss) Then
     k = dic(ss)
   Else
     kk = kk + 1         'はじめてのKeyのときは
     dic(ss) = kk        '配列内の行番号を決め
     k = kk
     For j = 1 To 5       '配列に1〜5列のデータを転記
       rv(j, k) = vv(i, j)
     Next
   End If
   rv(6, k) = rv(6, k) + vv(i, 6) 'k番目のKey data 集計
 Next
 Set dic = Nothing
 
' ReDim Preserve rv(1 To 6, kk)
 With Worksheets("data編集").[A1]
   .CurrentRegion.ClearContents
   .Resize(kk + 1, 6).Value = Application.Transpose(rv)
 End With
End Sub

【57881】Re:データ集計の方法
発言  kanabun  - 08/9/18(木) 21:59 -

引用なし
パスワード
   あと、ひとつ判らないのは、
dataシートの 1列目の DATE の取り扱いです。

これは 分類のキーには含まれていないようだけれど、
data編集 シートにはちゃんと存在します。
もしレコードが複数あったばあい、この日付データは
最初に現れた日付を転記すればいいのでしょうか?
それとも、重複キーのレコードが現れるたびに
更新していって、結局、最後の日付が 別シートに送られる
のでしょうか?

【57937】Re:データ集計の方法
お礼  MIRURU  - 08/9/22(月) 11:30 -

引用なし
パスワード
   kanabun さん:
Hirofumi さん :

アドバイスありがとうございます。
早速、やってみます。
でも、多分すんなりと解決できそうにもないので、もしそのときは
また、アドバイスお願いします

これから、試してみます

ありがとうございました

4199 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free