Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
7006 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【41447】３つの表を１つに集計 Help me!! 06/8/10(木) 14:59 質問[未読]
【41484】Re:３つの表を１つに集計 ナイスプログラム 06/8/12(土) 0:38 質問[未読]
【41645】Re:３つの表を１つに集計 ℃素人 06/8/18(金) 8:52 発言[未読]
【41838】Re:３つの表を１つに集計 ナイスプログラム 06/8/23(水) 22:48 回答[未読]
【41663】Re:３つの表を１つに集計 Kein 06/8/18(金) 16:48 回答[未読]
【41447】３つの表を１つに集計
質問  Help me!!  - 06/8/10(木) 14:59 -
引用なし
パスワード
   久しぶりの質問です。
非常に困っています。

助けてください。
お願いします。


３つの表があります。（下記参照)
book1のsheet1
　　 A　　　　　B　　　　　 C　　　　　　　D
得意先名称　売上金額1　　 コード　　　　担当者名
株式会社A　　 1000　　　　 123　　　　　　鈴木
有限会社B　　 2000　　　　 456　　　　　　佐藤
有限会社C　　 3000　　　　 456　　　　　　佐藤
　　・　　　　　・　　　　　・　　　　　　　・
　　・　　　　　・　　　　　・　　　　　　　・
　　・　　　　　・　　　　　・　　　　　　　・

book1のsheet2
　　 A　　　　　B　　　　　 C　　　　　　　D
得意先名称　売上金額2　　コード　　　　担当者名
株式会社A　　 4000　　　　 123　　　　　　鈴木
有限会社B　　 5000　　　　 456　　　　　　佐藤
有限会社C　　 6000　　　　 456　　　　　　佐藤
　　・　　　　　・　　　　　・　　　　　　　・
　　・　　　　　・　　　　　・　　　　　　　・
　　・　　　　　・　　　　　・　　　　　　　・

book1のsheet3
　　 A　　　　　B　　　　　 C　　　　　　　D
得意先名称　売上金額3　　 コード　　　　担当者名
株式会社A　　 7000　　　　 123　　　　　　鈴木
有限会社B　　 8000　　　　 456　　　　　　佐藤
有限会社C　　 9000　　　　 456　　　　　　佐藤
　　・　　　　　・　　　　　・　　　　　　　・
　　・　　　　　・　　　　　・　　　　　　　・
　　・　　　　　・　　　　　・　　　　　　　・

があります

この３つの表を下のようにVBAで集計表を作りたいと思ってます。

完成図

　　 A　　　　　　　B　　　　　　 C　　　　　　　　D　　　　　　　　E
　 担当者　　　　得意先名　　　売上金額１　　　売上金額２　　　売上金額３
　　佐藤　　　　株式会社A　　　　1000　　　　　　4000　　　　　　 7000　　
　　　　　　　　有限会社C　　 　 3000　　　　　　6000　　　　　　 9000
　　佐藤計　　　　　　　　　　　 4000　　　　　 10000　　　　　　16000
　　鈴木　　　　有限会社B　　　　2000　　　　　　5000　　　　　　 8000
　　・　　　　　　・　　　　　　　・　　　　　　　・　　　　　　　・
　　・　　　　　　・　　　　　　　・　　　　　　　・　　　　　　　・
　　・　　　　　　・　　　　　　　・　　　　　　　・　　　　　　　・

現在は、各３つの表をピボットテーブルで集計して、売上金額３が入っているピボットテーブルで得意先名称をキーにしてVlookupで売上１，２をくっつけいます。
なぜかというと、売上３はすべての得意先がもっています。売上１，２は得意先によってはデータが無い場合があります。
この場合完成表の中では「０」にしてもらってかまいません。
ものすごく面倒で困っています。

どなたかお助けください。
よろしくお願いします。
【41484】Re:３つの表を１つに集計
質問  ナイスプログラム WEB  - 06/8/12(土) 0:38 -
引用なし
パスワード
   　今晩は。
２次元配列を使うと良いと思いますが、コードは担当者のコードですか？
【41645】Re:３つの表を１つに集計
発言  ℃素人  - 06/8/18(金) 8:52 -
引用なし
パスワード
   ▼ナイスプログラム さん：
ご返信ありがとうございます。

コードとは担当者のコードです。
別に無くてものですが、念のため入れてあります。
集計はコードでは無くて担当者名でできればありがたいです。

よろしくお願いします。
【41663】Re:３つの表を１つに集計
回答  Kein  - 06/8/18(金) 16:48 -
引用なし
パスワード
   ちから技ですが、こちらのテストでは成功しました。
完成図を表示するシートの名前を "集計" とします。

Sub Data_集計()
　 Dim Sh As Worksheet, WS As Worksheet
　 Dim C As Range, FR As Range, MyR As Range
　 Dim Ary As Variant, MyV As Variant, V As Variant
　 Dim i As Long, Cnt As Long
　 Dim List() As String
　
　 Set Sh = Worksheets("集計")
　 Ary = Array("担当者", "得意先名", _
　 "売上金額１", "売上金額２", "売上金額３")
　 Application.ScreenUpdating = False
　 Sh.Cells.ClearContents
　 Sh.Range("A1:E1").Value = Ary
　 With Worksheets("Sheet3")
　　　MyV = .Range("A2", .Range("A65536").End(xlUp)).Value
　 End With
　 Cnt = UBound(MyV): ReDim List(i): List(i) = "z"
　 For Each WS In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
　　　For Each C In WS.Range("D2", WS.Range("D65536").End(xlUp))
　　　　 If IsError(Application.Match(C.Value, List(), 0)) Then
　　　　　　i = i + 1: ReDim Preserve List(i)
　　　　　　List(i) = C.Value
　　　　 End If
　　　Next
　 Next
　 For Each V In List
　　　If CStr(V) <> "z" Then
　　　　 With Sh.Range("B65536").End(xlUp)
　　　　　　.Offset(2).Resize(Cnt).Value = MyV
　　　　　　.Offset(2, -1).Value = CStr(V)
　　　　 End With
　　　End If
　 Next
　 i = 1
　 For Each WS In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
　　　For Each C In WS.Range("D2", WS.Range("D65536").End(xlUp))
　　　　 xR = Application.Match(C.Value, Sh.Range("A:A"), 0)
　　　　 Set FR = Sh.Cells(xR, 1).CurrentRegion _
　　　　 .Find(C.Offset(, -3).Value, , xlValues)
　　　　 If Not FR Is Nothing Then
　　　　　　FR.Offset(, i).Value = C.Offset(, -2).Value
　　　　　　Set FR = Nothing
　　　　 End If
　　　Next
　　　i = i + 1
　 Next
　 Sh.Rows("2:2").Delete xlSiftUp
　 Set MyR = Sh.Range("B1", Sh.Range("B65536").End(xlUp).Offset(1)) _
　 .SpecialCells(4)
　 MyR.Offset(, -1).FormulaR1C1 = "=R[-" & Cnt & "]C&"" 計"""
　 Intersect(MyR.EntireRow, Sh.Range("C:E")).FormulaR1C1 = _
　 "=SUM(R[-" & Cnt & "]C:R[-1]C)"
　 Application.ScreenUpdating = True
　 Erase List: Set MyR = Nothing: Set Sh = Nothing
End Sub
【41838】Re:３つの表を１つに集計
回答  ナイスプログラム WEB  - 06/8/23(水) 22:48 -
引用なし
パスワード
   　今晩は。

　やって見ました。一応テストはしていますが、バグがあるかもしれないので、
色々動かしてみて下さい。


Option Explicit
Option Base 1

Dim sinki As Object
Dim vv1 As Variant, vv2 As Variant, vv3 As Variant, vv4 As Variant
Dim ir1 As Integer, ic1 As Integer, ir2 As Integer, ic2 As Integer
Dim code As Integer
Dim name As String, customer As String
Dim price As Long
Dim start As Boolean


Sub 担当者()

vv1 = ThisWorkbook.Worksheets("sheet1").Range("a1").CurrentRegion.Value
vv2 = ThisWorkbook.Worksheets("sheet2").Range("a1").CurrentRegion.Value
vv3 = ThisWorkbook.Worksheets("sheet3").Range("a1").CurrentRegion.Value

ir1 = 1
ic1 = 3

Workbooks.Add
Set sinki = ActiveWorkbook

Call 新規記入(vv1)
Call 新規記入(vv2)
Call 新規記入(vv3)

Range("A1").Sort Key1:=Range("A2"), Header:=xlGuess
Range("C2").Sort Key1:=Range("C2"), Header:=xlGuess

vv1 = sinki.ActiveSheet.Range("a1").CurrentRegion.Value

表編集


End Sub

Private Sub 新規記入(vv)

Dim i As Integer

ir2 = ir1 + UBound(vv, 1) - 1
ic2 = UBound(vv, 2)

Range(Cells(ir1, 1), Cells(ir2, ic2)).Value = vv

For i = ir1 To ir2
　　Cells(i, ic2 + 1).Value = ic1
Next

If ir1 > 1 Then Rows(ir1).EntireRow.Delete
ir1 = Range("a65535").End(xlUp).Row + 1
ic1 = ic1 + 1

End Sub

Private Sub 表編集()

Dim ssv As Variant
Dim i As Integer

sinki.ActiveSheet.Cells.ClearContents

ssv = Array("担当者", "得意先名", "売上金額１", "売上金額２", "売上金額３")
For i = 1 To 5
　　Cells(1, i).Value = ssv(i)
Next

ir1 = 2
ir2 = 1
For i = 2 To UBound(vv1, 1)
　　If vv1(i, 3) <> code Then
　　　　If ir2 > 1 Then
　　　　　　ir2 = ir2 + 1
　　　　　　合計
　　　　End If
　　　　start = True
　　　　code = vv1(i, 3)
　　　　name = vv1(i, 4)
　　End If
　　
　　If customer <> vv1(i, 1) Then
　　　　customer = vv1(i, 1)
　　　　If start = False Then ir2 = ir2 + 1
　　End If
　　　　
　　price = vv1(i, 2)
　　ic1 = vv1(i, 5)
　　記入
　　　　
Next
ir2 = ir2 + 1
合計

End Sub

Private Sub 記入()

If start = True Then
　　ir2 = ir2 + 1
　　Cells(ir2, 1).Value = name
　　start = False
End If

Cells(ir2, 2).Value = customer
Cells(ir2, ic1).Value = price

End Sub

Private Sub 合計()

Dim i As Integer, j As Integer, total As Integer

For j = 3 To 5
　　For i = ir1 To ir2 - 1
　　　　
　　　　 total = total + Cells(i, j).Value
　　　　
　　Next
　　Cells(ir2, j).Value = total
　　total = 0
Next

Cells(ir2, 2).Value = name & "合計"
ir1 = ir2 + 1


End Sub
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
7006 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free