Results of 1 - 1 of about 48831 for A�����������������������... (0.009 sec.)
- [[20180413111544]]
- #score: 1420
- @digest: 755a595eb62f9ef5066de35108c9d295
- @id: 76105
- @mdate: 2018-04-13T23:52:27Z
- @size: 8845
- @type: text/plain
- #keywords: ル) (10981), sht2 (7071), 横並 (5341), むー (5223), 縦並 (4676), mytbl (4327), item (3096), ubound (2583), rg (2440), mydic (2333), 列) (2246), 目( (1789), 2018 (1661), scripting (1601), keys (1590), ーこ (1576), offset (1505), dictionary (1443), preserve (1442), exists (1301), 総計 (1291), entirecolumn (1217), 金) (1205), createobject (1176), 700 (1121), evaluate (1094), value (1091), rng (1071), mya (1054), resize (1035), variant (1000), ナン (1000)
- 『縦並びのデータを横並びにしたい』（むーこ）
質問です:以下のような縦並びのデータを、横並びで表示をしたいです。 またデータを横並びにする際に、重複する項目は数値を加算して表示したいです。 【元データ】 項目(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 ---- Sub main()'データは1行目からスタート 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 ---- mm様 ご回答ありがとうございます。 思い通りの動作に感激しております。 今からコードの解読します。 （むーこ） 2018/04/13(金) 16:49 ---- seiya様 ご回答ありがとうございます。 横並びにはなったのですが、同じ項目があった場合は数値を足したいのです。 こちらのコードも勉強させていただきます。 （むーこ） 2018/04/13(金) 16:59 ---- ああ、、 今出先なので、帰ってから見直します。 （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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201804/20180413111544.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97018 documents and 608145 words.
訪問者：