id:naranara19
ポイントあり200ptベストアンサーあり
コンピュータ

1423132555 表関係のエクセルマクロにご協力お願いいたします。



商品名と、商品番号、それを保管している場所がそれぞれのシートに

わかれています。その情報をまとめたいのです。

詳しくは画像をご確認くださいませ。


「★」というシート、「場所」というシートにある情報を「まとめ」というシートに上から順にまとめます。

（恐れ入りますが、関数でできるというご回答はご遠慮くださいませ。）

どうかよろしくお願いいたします。

回答の条件
  • 1人3回まで
  • 登録：
  • 終了：2015/02/12 19:40:04
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。
id:naranara19

質問者から

リセール京都買取2015/02/05 23:04:48

「場所」シートの見出し部分は適時変わります。一定しません。

しかし、場所のすぐ右側に商品があるときには、必ず商品名があり、同じ場所にもう１つあった場合はすぐ真下にと連続していきます。空白になることがありますが、それがその場所にある商品は終了ということになります。空白もなく、いきなり次の見出しがあらわれるときも、その場所ではもうないということになります。

規約違反として通知

ベストアンサー

id:a-kuma3 No.1

回答回数4973ベストアンサー獲得回数2154

ポイント200pt

マクロを書いてみました。

Const SPEED_UP = False          ' True で速くなる
Const MAX_ROW = 10000           ' 突っ走るのが怖いので

Sub Summarize()

    On Error GoTo ErrorHandler

    Set s_master = Worksheets("★")
    Set s_place = Worksheets("場所")
    Set s_summarize = Worksheets("まとめ")
    s_summarize.Range("A2:C" & MAX_ROW).Clear

    If SPEED_UP Then
        'ワークシートに描画しない
        Application.ScreenUpdating = False
    End If

    ' 商品マスタの読み込み 
    Set master = CreateObject("Scripting.Dictionary")
    For r = 2 To MAX_ROW
        Set Name = s_master.Cells(r, 1)
        If IsEmpty(Name) Then
            Exit For
        Else
            master.Add Name.Value, s_master.Cells(r, 11)
            Debug.Print Name.Value & ", " & s_master.Cells(r, 11)
        End If
    Next

    ' 場所シートから集計
    place_first = 0
    place_name = ""
    r_write = 2
    For c = 1 To 9 Step 2

        blank = 0
        r = 1
        Do While blank < 50
            Set place = s_place.Cells(r, c)
            Set goods = s_place.Cells(r, c + 1)

            ' ひとつ前のブロックを、商品番号の降順でソート
            If IsEmpty(goods) Or Not IsEmpty(place) And place_name <> place.Value Then
                If place_first <> 0 Then
                    If place_first <> r_write - 1 Then
						' この辺りを修正してます
                        s_summarize.Range(s_summarize.Cells(place_first, 2), s_summarize.Cells(r_write - 1, 3)) _
                            .Sort Key1:=s_summarize.Cells(place_first, 3), order1:=xlDescending
                    End If
                End If
                place_first = 0
                place_name = ""
            End If

            ' まとめシートへ書き込み
            If IsEmpty(goods) Then
                blank = blank + 1
            Else
                blank = 0
                If place_first = 0 Then
                    place_first = r_write
                    place_name = place.Value
                End If
                s_summarize.Cells(r_write, 1).Value = place.Value
                s_summarize.Cells(r_write, 2).Value = goods.Value
                s_summarize.Cells(r_write, 3).Value = master.Item(goods.Value)
                r_write = r_write + 1

            End If

            r = r + 1

            ' 念のため
            If r > MAX_ROW Then
                MsgBox "!!!!! 強制 Break !!!!!"
                Exit Do
            End If

            DoEvents

        Loop

    Next


FINAL:
    If SPEED_UP Then
        '結果を描画する
        Application.ScreenUpdating = True
    End If
    Exit Sub

ErrorHandler:
    GoTo FINAL

End Sub

多分、大丈夫だとは思いますが、念のため、「場所」シートの 10000行まで行くと強制終了するようにしてます。
シートのデータがもっとたくさんあるときには、先頭の MAX_ROW を大きくしてください。

シートの描画をしてるので、データが多いと、ちょっと遅いです。
動作の確認ができたら、先頭にある SPEED_UP を True にすると、描画をしなくなるので、ちょっと速くなります。



追記です。
見づらくなるので、先の回答のコードを修正しました。

他28件のコメントを見る
id:a-kuma3

セルの書式をすべてコピーするようにしました。その代わり、処理が随分と遅くなっちゃいました　(´・ω・｀)

Const SPEED_UP = False          ' True で速くなる
Const MAX_ROW = 10000           ' 突っ走るのが怖いので

Sub Summarize()

    On Error GoTo ErrorHandler

    Set s_master = Worksheets("★")
    Set s_place = Worksheets("場所")
    Set s_summarize = Worksheets("まとめ")
    s_summarize.Range("A2:C" & MAX_ROW).Clear

    If SPEED_UP Then
        'ワークシートに描画しない
        Application.ScreenUpdating = False
    End If

    ' 商品マスタの読み込み
    Set master = CreateObject("Scripting.Dictionary")
    For r = 2 To MAX_ROW
        Set Name = s_master.Cells(r, 1)
        If IsEmpty(Name) Or Name.Value = "" Then        ' ※ここを変えました
            Exit For
        Else
            master.Add Name.Value, s_master.Cells(r, 11)
            Debug.Print Name.Value & ", " & s_master.Cells(r, 11)
        End If
    Next

    ' 場所シートから集計
    place_first = 0
    place_name = ""
    r_write = 2
    For c = 1 To 9 Step 2

        blank = 0
        r = 1
        Do While blank < 50
            Set place = s_place.Cells(r, c)
            Set goods = s_place.Cells(r, c + 1)

            ' ひとつ前のブロックを、商品番号の降順でソート
            If IsEmpty(goods) Or Not IsEmpty(place) And place_name <> place.Value Then
                If place_first <> 0 Then
                    If place_first <> r_write - 1 Then
                        s_summarize.Range(s_summarize.Cells(place_first, 2), s_summarize.Cells(r_write - 1, 3)) _
                            .Sort Key1:=s_summarize.Cells(place_first, 3), order1:=xlDescending
                    End If
                End If
                place_first = 0
                place_name = ""
            End If

            ' まとめシートへ書き込み
            If IsEmpty(goods) Then
                blank = blank + 1
            Else
                blank = 0
                If place_first = 0 Then
                    place_first = r_write
                    place_name = place.Value
                End If
                Call copy_cell(s_summarize.Cells(r_write, 1), place)
                Call copy_cell(s_summarize.Cells(r_write, 2), goods)
                Call copy_cell(s_summarize.Cells(r_write, 3), master.Item(goods.Value))
                r_write = r_write + 1

            End If

            r = r + 1

            ' 念のため
            If r > MAX_ROW Then
                MsgBox "!!!!! 強制 Break !!!!!"
                Exit Do
            End If

            DoEvents

        Loop

    Next


FINAL:
    If SPEED_UP Then
        '結果を描画する
        Application.ScreenUpdating = True
    End If
    Exit Sub

ErrorHandler:
    GoTo FINAL

End Sub


Sub copy_cell(c_to, c_from)
    If Not IsEmpty(c_from) Then
        c_to.Value = c_from.Value
        c_from.Copy
        c_to.PasteSpecial xlPasteFormats
    End If
End Sub

セルの「縮小して全体を表示する」も複写されるので、「まとめ」シートの B列や C列は幅を広げてください。

2015/02/25 19:01:48
id:naranara19

完璧でした。早すぎて素晴らしいです。処理も十分なスピードです。おそらく普段のお仕事もまわりから大変信頼されている方だと思いました。ポイントは本日別途送信いたします。本当に有難うございましました。

2015/02/25 20:07:57

その他の回答（0件）

id:a-kuma3 No.1

回答回数4973ベストアンサー獲得回数2154ここでベストアンサー

ポイント200pt

マクロを書いてみました。

Const SPEED_UP = False          ' True で速くなる
Const MAX_ROW = 10000           ' 突っ走るのが怖いので

Sub Summarize()

    On Error GoTo ErrorHandler

    Set s_master = Worksheets("★")
    Set s_place = Worksheets("場所")
    Set s_summarize = Worksheets("まとめ")
    s_summarize.Range("A2:C" & MAX_ROW).Clear

    If SPEED_UP Then
        'ワークシートに描画しない
        Application.ScreenUpdating = False
    End If

    ' 商品マスタの読み込み 
    Set master = CreateObject("Scripting.Dictionary")
    For r = 2 To MAX_ROW
        Set Name = s_master.Cells(r, 1)
        If IsEmpty(Name) Then
            Exit For
        Else
            master.Add Name.Value, s_master.Cells(r, 11)
            Debug.Print Name.Value & ", " & s_master.Cells(r, 11)
        End If
    Next

    ' 場所シートから集計
    place_first = 0
    place_name = ""
    r_write = 2
    For c = 1 To 9 Step 2

        blank = 0
        r = 1
        Do While blank < 50
            Set place = s_place.Cells(r, c)
            Set goods = s_place.Cells(r, c + 1)

            ' ひとつ前のブロックを、商品番号の降順でソート
            If IsEmpty(goods) Or Not IsEmpty(place) And place_name <> place.Value Then
                If place_first <> 0 Then
                    If place_first <> r_write - 1 Then
						' この辺りを修正してます
                        s_summarize.Range(s_summarize.Cells(place_first, 2), s_summarize.Cells(r_write - 1, 3)) _
                            .Sort Key1:=s_summarize.Cells(place_first, 3), order1:=xlDescending
                    End If
                End If
                place_first = 0
                place_name = ""
            End If

            ' まとめシートへ書き込み
            If IsEmpty(goods) Then
                blank = blank + 1
            Else
                blank = 0
                If place_first = 0 Then
                    place_first = r_write
                    place_name = place.Value
                End If
                s_summarize.Cells(r_write, 1).Value = place.Value
                s_summarize.Cells(r_write, 2).Value = goods.Value
                s_summarize.Cells(r_write, 3).Value = master.Item(goods.Value)
                r_write = r_write + 1

            End If

            r = r + 1

            ' 念のため
            If r > MAX_ROW Then
                MsgBox "!!!!! 強制 Break !!!!!"
                Exit Do
            End If

            DoEvents

        Loop

    Next


FINAL:
    If SPEED_UP Then
        '結果を描画する
        Application.ScreenUpdating = True
    End If
    Exit Sub

ErrorHandler:
    GoTo FINAL

End Sub

多分、大丈夫だとは思いますが、念のため、「場所」シートの 10000行まで行くと強制終了するようにしてます。
シートのデータがもっとたくさんあるときには、先頭の MAX_ROW を大きくしてください。

シートの描画をしてるので、データが多いと、ちょっと遅いです。
動作の確認ができたら、先頭にある SPEED_UP を True にすると、描画をしなくなるので、ちょっと速くなります。



追記です。
見づらくなるので、先の回答のコードを修正しました。

他28件のコメントを見る
id:a-kuma3

セルの書式をすべてコピーするようにしました。その代わり、処理が随分と遅くなっちゃいました　(´・ω・｀)

Const SPEED_UP = False          ' True で速くなる
Const MAX_ROW = 10000           ' 突っ走るのが怖いので

Sub Summarize()

    On Error GoTo ErrorHandler

    Set s_master = Worksheets("★")
    Set s_place = Worksheets("場所")
    Set s_summarize = Worksheets("まとめ")
    s_summarize.Range("A2:C" & MAX_ROW).Clear

    If SPEED_UP Then
        'ワークシートに描画しない
        Application.ScreenUpdating = False
    End If

    ' 商品マスタの読み込み
    Set master = CreateObject("Scripting.Dictionary")
    For r = 2 To MAX_ROW
        Set Name = s_master.Cells(r, 1)
        If IsEmpty(Name) Or Name.Value = "" Then        ' ※ここを変えました
            Exit For
        Else
            master.Add Name.Value, s_master.Cells(r, 11)
            Debug.Print Name.Value & ", " & s_master.Cells(r, 11)
        End If
    Next

    ' 場所シートから集計
    place_first = 0
    place_name = ""
    r_write = 2
    For c = 1 To 9 Step 2

        blank = 0
        r = 1
        Do While blank < 50
            Set place = s_place.Cells(r, c)
            Set goods = s_place.Cells(r, c + 1)

            ' ひとつ前のブロックを、商品番号の降順でソート
            If IsEmpty(goods) Or Not IsEmpty(place) And place_name <> place.Value Then
                If place_first <> 0 Then
                    If place_first <> r_write - 1 Then
                        s_summarize.Range(s_summarize.Cells(place_first, 2), s_summarize.Cells(r_write - 1, 3)) _
                            .Sort Key1:=s_summarize.Cells(place_first, 3), order1:=xlDescending
                    End If
                End If
                place_first = 0
                place_name = ""
            End If

            ' まとめシートへ書き込み
            If IsEmpty(goods) Then
                blank = blank + 1
            Else
                blank = 0
                If place_first = 0 Then
                    place_first = r_write
                    place_name = place.Value
                End If
                Call copy_cell(s_summarize.Cells(r_write, 1), place)
                Call copy_cell(s_summarize.Cells(r_write, 2), goods)
                Call copy_cell(s_summarize.Cells(r_write, 3), master.Item(goods.Value))
                r_write = r_write + 1

            End If

            r = r + 1

            ' 念のため
            If r > MAX_ROW Then
                MsgBox "!!!!! 強制 Break !!!!!"
                Exit Do
            End If

            DoEvents

        Loop

    Next


FINAL:
    If SPEED_UP Then
        '結果を描画する
        Application.ScreenUpdating = True
    End If
    Exit Sub

ErrorHandler:
    GoTo FINAL

End Sub


Sub copy_cell(c_to, c_from)
    If Not IsEmpty(c_from) Then
        c_to.Value = c_from.Value
        c_from.Copy
        c_to.PasteSpecial xlPasteFormats
    End If
End Sub

セルの「縮小して全体を表示する」も複写されるので、「まとめ」シートの B列や C列は幅を広げてください。

2015/02/25 19:01:48
id:naranara19

完璧でした。早すぎて素晴らしいです。処理も十分なスピードです。おそらく普段のお仕事もまわりから大変信頼されている方だと思いました。ポイントは本日別途送信いたします。本当に有難うございましました。

2015/02/25 20:07:57
id:naranara19

質問者から

リセール京都買取2015/02/14 08:05:46

ありがとうございました。やってみたのですが、やはり、表示されないのです。On Error ～ の行をコメントアウト←この部分はわかりませんでした。ぜひ教えていただけないでしょうか？エクセルは97-2003ブックで保存しております。

規約違反として通知

コメント（4件)

  • id:ceramic-cups
    世良満久 2015/02/06 22:03:38
    「場所シート」は何故複数行に分割しなければならないのでしょうか？Excel2007以降は1,048,576行までサポートしているので連続した表をテーブルとして扱えば構造がシンプルになると思います。
    vlookupとピボットテーブルで対応できそうな気がするのですが、マクロ記述希望のようですので詳しい方の回答を待って見てみたいと思います。
    世良満久
    〆
  • id:naranara19
    リセール京都買取 2015/02/07 11:40:11
    こんにちは。ありがとうございます。単にA4用紙に収まるようにしているのです（汗）

    そのために複雑になってすみません。
  • id:ceramic-cups
    世良満久 2015/02/08 07:11:13
    場所シートを複数行で印刷できる別シートを作成するか、マクロで印刷専用シートを追加作成するのも解決策の一つになるかもしれませんね。せら〆
  • id:naranara19
    リセール京都買取 2015/02/12 16:56:47
    「せら」さん、何度もお付き合いいただきありがとうございます！

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ