[[20180813172219]]　『横並びの複数セルの項目から検索し結果を返したい』（お母さん）　ページの最後に飛ぶ

『横並びの複数セルの項目から検索し結果を返したいです』（お母さん）

例）
　名1　発注数1　名2　発注数2　　名3　発注数3　
Ａ　あ　　　　2　　　　い　　　　1　　　う　　　　4
Ｂ　い　　　 4　　　　う　　　　3　　　あ　　　　2
Ｃ　う　　　　1　　　　あ　　　　2

上記の様に横並びに資材と発注数がランダムに並んでいます
これを下記の様に全て同じ位置に同じ資材が来るように
別のセルに返したいです

Ａ　あ　　　　2　　　　い　　　　1　　　う　　　4
Ｂ　あ　　　　2　　　　い　　　　4　　　う　　　3
Ｃ　あ　　　　2　　　　　　　　　　　　う　　　1

何かいい方法はないでしょうか。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

Sub main()
'Sheet1からSheet2に並び替え Sheet1のA列に、Ａ，Ｂ，Ｃ等と記載済。データは１行目から

    Dim dic As Object, dic2 As Object, k As Variant, c As Range, rw As Long
    Set dic = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    For Each c In Sheets("Sheet1").UsedRange
        If IsNumeric(c.Value) And c.Value <> "" Then dic(c.Offset(, -1).Value) = True
    Next c
    Sheets("Sheet2").Cells.Clear
    Sheets("Sheet1").Columns(1).Copy Sheets("Sheet2").Range("A1")
    For Each k In dic
        For Each c In Sheets("Sheet1").UsedRange
            If c.Value = k Then
                rw = c.Row
                If dic2(k) = Empty Then
                    dic2(k) = Sheets("Sheet2").Cells(rw, Columns.Count).End(xlToLeft).Offset(, 1).Column
                End If
                Sheets("Sheet2").Cells(rw, dic2(k)).Resize(, 2).Value = c.Resize(, 2).Value
            End If
        Next c
    Next k
End Sub
（mm） 2018/08/13(月) 18:33

 Sheet1のB1に名1、C1に発注数1....ということで
 Sheet1のデータを並び替え

 Sub tset()
     Dim a, e, i As Long, ii As Long, AL As Object
     Set AL = CreateObject("System.Collections.ArrayList")
     With Sheets("sheet1").Cells(1).CurrentRegion
         a = .Value
         With CreateObject("Scripting.Dictionary")
             For i = 2 To UBound(a, 1)
                 Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
                 For ii = 2 To UBound(a, 2) Step 2
                     If a(i, ii) <> "" Then
                         If Not AL.Contains(a(i, ii)) Then AL.Add a(i, ii)
                         .Item(a(i, 1))(a(i, ii)) = a(i, ii + 1)
                     End If
                 Next
             Next
             ReDim a(1 To .Count, 1 To AL.Count * 2 + 1): AL.Sort
             For i = 0 To .Count - 1
                 a(i + 1, 1) = .keys()(i)
                 For Each e In .items()(i).keys
                     a(i + 1, (AL.IndexOf_3(e)) * 2 + 2) = e
                     a(i + 1, (AL.IndexOf_3(e)) * 2 + 3) = .items()(i)(e)
                 Next
             Next
         End With
         .Offset(1).Resize(.Rows.Count - 1).Resize(, UBound(a, 2)).Value = a
         If UBound(a, 2) > .Columns.Count Then
             .Range("b1:c1").AutoFill .Range("b1:c1").Resize(, UBound(a, 2) - 1)
         End If
     End With
 End Sub
（seiya） 2018/08/13(月) 19:30

こんな表の方が無駄がないのでは？

余計なお世話ですね。ごめんなさい。

（マナ） 2018/08/13(月) 20:38

mmさん、seiyaさん、マナさん

ご回答ありがとうございました！

ただ、私に知識が無さすぎで、ちんぷんかんぷんです(-"-)
どうもすみませんでした。

もう少し勉強します

マナさん、
最終的な結果の形はマナさんのおっしゃる形にしたいところでした(^_^;)

と～ってもお時間を持て余すことがあって、仕方ないな。。。と
思って頂けたときに、もうひと段階手前のご説明を頂けるたら幸いです<(_ _)>

ありがとうございました。

（お母さん） 2018/08/14(火) 09:49

 1) エクセル画面からAlt + F11 でVBEを表示
 2) 挿入-標準モジュール で出てきた右画面の空白部分に
    提示したコードを貼り付けてAlt + Q でエクセル画面
    に戻る。
 3) Alt + F11 でマクロを選択して実行

（seiya） 2018/08/14(火) 10:17

＞最終的な結果の形はマナさんのおっしゃる形にしたいところでした(^_^;)

＞私に知識が無さすぎで、ちんぷんかんぷんです(-"-)

ということであれば、手作業での方法です。
文章だと長いですが、理解してしまえば簡単な作業です。

 １）A列をコピーして、名2の列の前に挿入
 ２）これを繰り返し、名3、名4、…の前にも挿入
 ３）D列以降の３列分のデータ（ただし見出し部分を除く）を選択
 ４）A列最下行の下にコピペ
 ５）３）４）を最後の列まで繰り返す
 ６）D列以降を削除
 ７）A1に見出しとして、適当な文字入力（例えば「部署」）

これで、こんな感じに３列データになります。

 部署	名1	発注数1
Ａ	あ	2
Ｂ	い	4
Ｃ	う	1
Ａ	い	1
Ｂ	う	3
Ｃ	あ	2
Ａ	う	4
Ｂ	あ	2
Ｃ

あとは、ピボットテーブルで集計するだけです。

（マナ） 2018/08/14(火) 10:35

皆さま

わかりました！マクロですね！

検証させて頂きましたところ、seiyaさんの方法は元のデータを並び替えてしまうという事で
並び替えは不可なのでダメでした<(_ _)>

mmさんの方法では、データが移行できたのですが
結果の資材名の順番が、元データで出て来た順？になっているようで
あ　い　う　という順番にはなりませんでした。。。<(_ _)>

最初の質問の条件が変わってしまいますが
結果はマナさんのおっしゃる形を希望しています
出てくる資材は7つで、結果は常に　あ　い　う　え　お　か　き　の順番で出るように
また、元データには、例えばＡに同じ資材が２回含まれる場合もあります
その場合は合計の発注数を返したいです

どうぞ、宜しくお願い致します

というコメントを打っているうちにご回答頂いていた様です
ありがとうございます
マナさんできましたら手作業の回数を少なく済ませたいです

上記の通りです、今一度　宜しくお願い致します

（お母さん） 2018/08/14(火) 10:57

seiyaさん

すみません、seiyaさんの方法は元データをコピーしてから作業すれば
なんの問題も無く十分な方法でした(^_^;)
ありがとうございました

ただ、並び替えですとエクセル判断の順番になってしまうと思うのですが
そこを思う通りの順番にする方法等あるのでしょうか？

お時間あるとき、教えて頂けたら幸いです

（お母さん） 2018/08/14(火) 11:26

何度もすみません！

補足です！

ＡＢＣの行には　Ａが２回、３回出てくることがありますが
これは纏めないでそれぞれそのままの結果が欲しいです

宜しくお願い致します
（お母さん） 2018/08/14(火) 11:33

 スマホからなので返信は遅くなります。
 具体的に何を基準に並べ替えするのでしょう？

 並べ替え前と並べ替え後の例があれば参考になります。
（seiya） 2018/08/14(火) 11:41

＞結果は常に　あ　い　う　え　お　か　き　の順番

＞ＡＢＣの行には　Ａが２回、３回出てくることがありますが
＞これは纏めないでそれぞれそのままの結果が欲しいです

ならば、予め１行めに資材名を入力しておき
SUMIFS関数で集計すればよいのでは？

（マナ） 2018/08/14(火) 12:34

B1から右に、あ、い、う、…と入力してあるとして
B2に入れる式
=SUMIFS(Sheet1!$C2:$O2,Sheet1!$B2:$N2,Sheet2!B$1)

（マナ） 2018/08/14(火) 12:45

 とりあえず、
 1) Sheet1のデータをSheet2に並べ替えて転記。
 2) 各行を纏めないで個別に並べ替え。

 Sub test()
     Dim a, b, i As Long, ii As Long, ub As Long, x, AL As Object
     Set AL = CreateObject("System.Collections.ArrayList")
     a = Sheets("sheet1").Cells(1).CurrentRegion.Value
     ub = UBound(a, 2)
     For i = 2 To UBound(a, 1)
         For ii = 2 To UBound(a, 2) Step 2
             If a(i, ii) <> "" Then
                 If Not AL.Contains(a(i, ii)) Then AL.Add a(i, ii)
             End If
         Next
     Next
     ReDim Preserve a(1 To UBound(a, 1), 1 To AL.Count * 2 + 1): AL.Sort
     For i = 2 To UBound(a, 1)
         b = Application.Index(a, i, 0)
         For ii = 2 To UBound(a, 2)
             a(i, ii) = Empty
         Next
         For ii = 2 To UBound(b) Step 2
             If b(ii) <> "" Then
                 x = AL.IndexOf_3(b(ii)) * 2 + 2
                 a(i, x) = b(ii): a(i, x + 1) = b(ii + 1)
             End If
         Next
     Next
     With Sheets("sheet2").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
         .CurrentRegion.ClearContents
         .Value = a
         If UBound(a, 2) > ub Then
             .Range("b1:c1").AutoFill .Range("b1:c1").Resize(, UBound(a, 2) - 1)
         End If
     End With
 End Sub

（seiya） 2018/08/14(火) 13:19

 バグ修正 13:53

 もしこの結果が良ければ、こっちの方が簡単なので。

 Sub PVish()
     Dim a, b, i As Long, ii As Long, x, AL As Object
     Set AL = CreateObject("System.Collections.ArrayList")
     a = Sheets("sheet1").Cells(1).CurrentRegion.Value
     For i = 2 To UBound(a, 1)
         For ii = 2 To UBound(a, 2) Step 2
             If (a(i, ii) <> "") * (Not AL.Contains(a(i, ii))) Then AL.Add a(i, ii)
     Next ii, i
     AL.Sort
     ReDim b(1 To UBound(a, 1) - 1, 1 To AL.Count + 1)
     For i = 2 To UBound(a, 1)
         b(i - 1, 1) = a(i, 1)
         For ii = 2 To UBound(a, 2) Step 2
             If a(i, ii) <> "" Then
                 x = AL.IndexOf_3(a(i, ii)) + 2
                 b(i - 1, x) = a(i, ii + 1)
             End If
         Next
     Next
     With Sheets("sheet2").Cells(1).Resize(, AL.Count + 1)
         .CurrentRegion.ClearContents
         .Offset(, 1).Resize(, AL.Count).Value = AL.ToArray
         .Rows(2).Resize(UBound(b, 1)).Value = b
     End With
 End Sub

（seiya） 2018/08/14(火) 14:22

マナさん、seiyaさん

ありがとうございます！

ちょっと仕事に没頭してました。
明日、確認させて頂きます<(_ _)>
（お母さん） 2018/08/14(火) 18:48

マナさん、seiyaさん

こんばんは。だいぶ返信が遅くなってしまいましたが
教えて頂いた通り試してみたところ
マナさんの方法で実践でき
日々の作業時間が短縮できました
本当にありがとうございました！

seiyaさんの後の方法も私が望んでいた結果に近いのですが
やはり並び順が思う通りではないのです。
項目が　あいうえおかきとあったら
例えば結果は
かきうえおあい　という思い通りの順にしたいのです
マクロもとても魅力的なので、ほんとに何もすることがなくて(笑)
お時間あるときに方法があれば教えて頂けたらと思います
本当にありがとうございました。

また、マクロなら出来そうな作業を新たな枠で質問させて頂こうと思っています
よろしければ相談に乗ってくださいm(__)m

ありがとうございました

（お母さん） 2018/08/21(火) 21:49

 >やはり並び順が思う通りではないのです。 
 >項目が　あ い う え お か き とあったら 
 >例えば結果は 
 >か き う え お あ い 　という思い通りの順にしたいのです

 それはあなたがそのようにしたいと言わないからです。
（seiya） 2018/08/21(火) 22:24

 >か き う え お あ い 　という思い通りの順にしたいのです

 Sub PVish()
     Dim a, e, i As Long, ii As Long, x, t As Long, r As Range, AL As Object
     Set AL = CreateObject("System.Collections.ArrayList")
     For Each e In Array("か", "き", "う", "え", "お", "あ", "い")
        AL.Add e
     Next
     t = AL.Count
     a = Sheets("sheet1").Cells(1).CurrentRegion.Value
     For i = 2 To UBound(a, 1)
         For ii = 2 To UBound(a, 2) Step 2
             If (a(i, ii) <> "") * (Not AL.Contains(a(i, ii))) Then AL.Add a(i, ii)
     Next ii, i
     If AL.Count > t Then AL.Sort_3 t, AL.Count - t, Nothing
     ReDim b(1 To UBound(a, 1) - 1, 1 To AL.Count + 1)
     For i = 2 To UBound(a, 1)
         b(i - 1, 1) = a(i, 1)
         For ii = 2 To UBound(a, 2) Step 2
             If a(i, ii) <> "" Then
                 x = AL.IndexOf_3(a(i, ii)) + 2
                 b(i - 1, x) = a(i, ii + 1)
             End If
         Next
     Next
     With Sheets("sheet2").Cells(1).Resize(, AL.Count + 1)
         .CurrentRegion.ClearContents
         .Offset(, 1).Resize(, AL.Count).Value = AL.ToArray
         .Rows(2).Resize(UBound(b, 1)).Value = b
     End With
 End Sub
（seiya） 2018/08/21(火) 23:06
 編集あり

seiyaさん

おおおお！できましたぁ！(^O^)／

具体的に何を基準に並べ替えするのでしょう？

並べ替え前と並べ替え後の例があれば参考になります。（seiya） 2018/08/14(火) 11:41

↑このコメントを頂いたときに、どう伝えればいいか思いつかず・・・
遠回りをさせてしまいました、大変失礼いたしました<(_ _)>

使わせて頂きます！ありがとうございました！

（お母さん） 2018/08/22(水) 12:44

seiyaさん

すみません。。。確認漏れがありました

Ａの行に　う　が２回出てくることがあります
その場合は発注数の合計を返したいです

今は、後に出て来た発注数が返されていると思います

よろしくお願いします<(_ _)>
（お母さん） 2018/08/23(木) 12:29

Sub main()

    Dim aws As Worksheet, ws As Worksheet, dic As Object, c As Range
    Set aws = ActiveSheet
    Set dic = CreateObject("scripting.dictionary")
    ar = Array("か", "き", "う", "え", "お", "あ", "い")
    Set ws = Worksheets.Add
    aws.Range("A1:A" & aws.Range("A" & Rows.Count).End(xlUp).Row).Copy ws.Range("A2")
    ws.Range("B1").Resize(, UBound(ar)) = ar
    For Each c In ws.Rows(1).SpecialCells(2)
        dic(c.Value) = c.Column
    Next c
    For Each c In ws.Columns(1).SpecialCells(2)
        dic(c.Value) = c.Row
    Next c
    For Each c In aws.Cells.SpecialCells(2)
        If c.Column > 1 And dic(c.Value) Then
            ws.Cells(dic(c.EntireRow.Cells(1).Value), dic(c.Value)).Value = Val(ws.Cells(dic(c.EntireRow.Cells(1).Value), dic(c.Value)).Value) + c.Offset(, 1).Value
        End If
    Next c
End Sub
（mm） 2018/08/23(木) 18:04

 単一行に複数の名前が存在するということですね？
 例のごとく、配列に無い名前は後方に昇順に列記ということで、

 以下に差し替えてください。

 Sub PVish()
     Dim a, e, i As Long, ii As Long, x, t As Long, r As Range, AL As Object
     Set AL = CreateObject("System.Collections.ArrayList")
     For Each e In Array("か", "き", "う", "え", "お", "あ", "い")
        AL.Add e
     Next
     t = AL.Count
     a = Sheets("sheet1").Cells(1).CurrentRegion.Value
     For i = 2 To UBound(a, 1)
         For ii = 2 To UBound(a, 2) Step 2
             If (a(i, ii) <> "") * (Not AL.Contains(a(i, ii))) Then AL.Add a(i, ii)
     Next ii, i
     If AL.Count > t Then AL.Sort_3 t, AL.Count - t, Nothing
     ReDim b(1 To UBound(a, 1) - 1, 1 To AL.Count + 1)
     For i = 2 To UBound(a, 1)
         b(i - 1, 1) = a(i, 1)
         For ii = 2 To UBound(a, 2) Step 2
             If a(i, ii) <> "" Then
                 x = AL.IndexOf_3(a(i, ii)) + 2
                 b(i - 1, x) = Val(b(i - 1, x)) + Val(a(i, ii + 1))
             End If
         Next
     Next
     With Sheets("sheet2").Cells(1).Resize(, AL.Count + 1)
         .CurrentRegion.ClearContents
         .Offset(, 1).Resize(, AL.Count).Value = AL.ToArray
         .Rows(2).Resize(UBound(b, 1)).Value = b
     End With
 End Sub
（seiya） 2018/08/23(木) 18:45

seiyaさん

ありがとうございます！

＞配列に無い名前は後方に昇順に列記ということで

完璧です！

ありがとうございました<(_ _)>
（お母さん） 2018/08/24(金) 13:58

mmさん

ありがとうございます。

すみません、こちらの方法はＡ列にＡＢＣ・・・という行ごとの名前のようなものは必要ですか？

ちょっと、まだうまく実行できていません<(_ _)>

（お母さん） 2018/08/24(金) 14:04

コメント返信：

[ 一覧(最新更新順) ]

[[20180813172219]] 『横並びの複数セルの項目から検索し結果を返したい』（お母さん） ページの最後に飛ぶ

[[20180813172219]]　『横並びの複数セルの項目から検索し結果を返したい』（お母さん）　ページの最後に飛ぶ