[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『縦並びのデータを横並びにしたい』（むーこ）
質問です：以下のような縦並びのデータを、横並びで表示をしたいです。
またデータを横並びにする際に、重複する項目は数値を加算して表示したいです。
【元データ】 項目(A列) 数値(B列) A 100 B 200 C 300 D 400 A 500 C 600 E 700
↓
【計算結果】
(D1セル) (E1セル) (F1セル) (G1セル) (H1セル) (I1セル) (J1セル) (K1セル) (L1セル) (M1セル)
A 600 B 200 C 900 D 400 E 700
同じ項目があれば数値を足す場合、どのようなマクロを組めば良いのでしょうか？
説明が下手で申し訳ございませんが、どなたかご教授お願い致します。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
ちょっと雑な書き方ですけど、
Option Explicit
Sub TEST()
Dim Dic As Object
Dim Keys
Dim Rng As Range
Dim i As Long, n As Long
Set Dic = CreateObject("Scripting.Dictionary")
For Each Rng In Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
If Dic.exists(Rng.Value) Then
Dic.Item(Rng.Value) = Application.Sum(Dic.Item(Rng.Value), Rng.Offset(, 1).Value)
Else
Dic.Add Rng.Value, Rng.Offset(, 1).Value
End If
Next Rng
Keys = Dic.Keys
n = 4
For i = 0 To Dic.Count - 1
Set Rng = Cells(1, n)
Rng.Offset(, i).Value = Keys(i)
Rng.Offset(, i + 1).Value = Dic.Item(Keys(i))
n = n + 1
Next i
Set Dic = Nothing
End Sub
でどうでしょう。
（ろっくん） 2018/04/13(金) 11:52
ろっくん様
上手く動作しました。
早急なご回答ありがとうございます。大変助かりました。
（むーこ） 2018/04/13(金) 12:04
【元データ】
ﾅﾝﾊﾞｰ(A列) 項目(B列) 数値(C列) 1 A 100 1 B 200 1 C 300 1 D 400 1 A 500 1 C 600 1 E 700 2 A 100 2 C 100 2 B 100 2 A 100 2 C 100 2 C 100
↓
【計算結果】
(E1セル)(E1セル) (F1セル) (G1セル) (G1セル) (H1セル) (I1セル) (J1セル) (K1セル) (L1セル) (M1セル)
1 A 600 B 200 C 900 D 400 E 700
2 A 200 C 300 B 100
（むーこ） 2018/04/13(金) 13:32
Dim sht1 As Worksheet, sht2 As Worksheet, c As Range, r As Range, rg As Range
Set sht1 = Sheets("Sheet1") '元データのシート名
Set sht2 = Sheets("Sheet2") '結果表示先のシート名
sht2.Cells.Delete
For Each c In sht1.Range("A:A").SpecialCells(xlCellTypeConstants)
Set r = sht2.Range("E:E").Find(c.Value)
If r Is Nothing Then
Set r = sht2.Range("E" & Rows.Count).End(xlUp).Offset(1)
End If
r.Value = c.Value
Set rg = r.EntireRow.Find(c.Offset(, 1).Value, , , xlWhole)
If rg Is Nothing Then
Set rg = sht2.Cells(r.Row, Columns.Count).End(xlToLeft).Offset(, 2)
If IsNumeric(rg.Offset(, -2).Value) Then Set rg = rg.Offset(, -1)
End If
rg.Value = c.Offset(, 1).Value
rg.Offset(, 1).Value = rg.Offset(, 1).Value + Val(c.Offset(, 2).Value)
Next c
End Sub
（mm） 2018/04/13(金) 14:52
こんな感じで
Sub test()
Dim a, i As Long, ii As Long, ub As Long
a = Cells(1).CurrentRegion.Resize(, 3).Value
ub = UBound(a, 2)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
.Item(a(i, 1)) = Array(.Count + 2, 3)
For ii = 1 To ub
a(.Count + 1, ii) = a(i, ii)
Next
Else
If UBound(a, 2) < .Item(a(i, 1))(1) + 2 Then
ReDim Preserve a(1 To UBound(a, 1), 1 To .Item(a(i, 1))(1) + 2)
End If
For ii = 2 To 3
a(.Item(a(i, 1))(0), .Item(a(i, 1))(1) + ii - 1) = a(i, ii)
Next
.Item(a(i, 1)) = Array(.Item(a(i, 1))(0), .Item(a(i, 1))(1) + 2)
End If
Next
i = .Count + 1
End With
With Range("d1").Resize(i, UBound(a, 2))
.EntireColumn.ClearContents
.Value = a
If ub < .Columns.Count Then
With .Range("b1:c1")
.Value = Evaluate("b1:c1&""1""")
.AutoFill .Resize(, UBound(a, 2) - 1)
End With
End If
.Columns.AutoFit
End With
End Sub
（seiya） 2018/04/13(金) 15:06
ああ、、 今出先なので、帰ってから見直します。 （seiya） 2018/04/13(金) 17:02
こういうことでしたね...
Sub test()
Dim a, i As Long, ii As Long, ub As Long, w
a = Cells(1).CurrentRegion.Resize(, 3).Value
ub = UBound(a, 2)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
.Item(a(i, 1)) = Array(.Count + 1, CreateObject("Scripting.Dictionary"))
.Item(a(i, 1))(1)(a(i, 2)) = ub
For ii = 1 To ub
a(.Count, ii) = a(i, ii)
Next
Else
w = .Item(a(i, 1))
If Not w(1).exists(a(i, 2)) Then
w(1)(a(i, 2)) = ub + w(1).Count * 2
If UBound(a, 2) < w(1)(a(i, 2)) Then
ReDim Preserve a(1 To UBound(a, 1), 1 To w(1)(a(i, 2)))
End If
a(w(0), w(1)(a(i, 2)) - 1) = a(i, 2)
a(w(0), w(1)(a(i, 2))) = a(i, 3)
Else
a(w(0), w(1)(a(i, 2))) = a(w(0), w(1)(a(i, 2))) + a(i, 3)
End If
.Item(a(i, 1)) = w
End If
Next
i = .Count
End With
With Range("d1").Resize(i, UBound(a, 2))
.EntireColumn.ClearContents
.Value = a
End With
End Sub
（seiya） 2018/04/13(金) 18:51
もうお腹いっぱいでしょうけど、せっかく書いたのでUpしておきます。
一応、↓こんな感じになりました。 1 A 600 B 200 C 900 D 400 E 700 2 A 200 C 300 B 100
Option Explicit
Sub てすと()
Dim MyTbl As Range
Dim MyA As Variant
Dim MyB As Variant
Dim v() As Variant
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim MyDic As Object
Dim i As Long
Dim n As Long
Dim k As Long
Dim r As Long
Set MyTbl = Range("A1", Range("A" & Rows.Count).End(xlUp))
MyA = MyTbl.Resize(, 2).Value
MyB = MyTbl.Resize(, 3).Value
Set MyDic = CreateObject("Scripting.Dictionary")
For i = LBound(MyA, 1) To UBound(MyA, 1)
x = Application.Index(MyA, i, 0)
x = Join(x, " ")
MyDic(x) = MyDic(x) + MyB(i, 3)
Next
x = MyDic.Keys
y = MyDic.Items
With MyTbl
n = Evaluate("SUM(1/COUNTIF(" & .Address & "," & .Address & "))")
End With
ReDim v(1 To n, 1 To 3)
r = 1
k = 1
z = Split(x(1), " ")
v(1, 1) = z(0)
For i = LBound(x) To UBound(x)
z = Split(x(i), " ")
If v(r, 1) <> z(0) Then
r = r + 1
k = 3
v(r, 1) = z(0)
v(r, 2) = z(1)
v(r, 3) = y(i)
Else
k = k + 2
If UBound(v, 2) < k Then
ReDim Preserve v(1 To n, 1 To k)
End If
v(r, k - 1) = z(1)
v(r, k) = y(i)
End If
Next
Range("A1").CurrentRegion.Offset(, 3).Clear
Range("D1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
Set MyDic = Nothing
Erase MyA, MyB, v, x, y, z
End Sub
朝起きてよく見たら無駄なところがあったので修正しました。m(__)m 2018/4/14 08:24 （SoulMan） 2018/04/13(金) 23:24
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=79788;id=excel
（マルチネス） 2018/04/14(土) 08:08
ピボットテーブルを使ってこんな形にするのが手間いらずでは？
A B C D E 総計
1 600 200 900 400 700 2,800
2 200 100 300 600
総計 800 300 1,200 400 700 3,400
（γ） 2018/04/14(土) 08:52
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.