人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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


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

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

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


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

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

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

1423132555
●拡大する

●質問者: naranara19
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

質問者から

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

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


1 ● a-kuma3
●200ポイント ベストアンサー

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

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 にすると、描画をしなくなるので、ちょっと速くなります。




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


naranara19さんのコメント
ご回答ありがとうございました。やってみたのですが、「まとめ」シートに何も書き出されませんでした。 まとめシートは場所の記号などはかかれておらず、白紙でございます。 もしかしたら、まとめシートに場所があらかじめ表示されるようにお考えだったでしょうか? お手数ですが、ご対応いただけないでしょうか? なお、上記のような認識でらっしゃいましたら、こちらの指示ミスだと思いますので、ポイント加算を考えております。 どうかよろしくお願い申し上げます。

a-kuma3さんのコメント
あれ、何も書かれませんか? 動作の確認をするときに、「まとめ」シートがアクティブな状態でしかやっていなかったので、一部、シートの指定が漏れてるところがありました m(_ _)m でも、質問にあるデータであれば、中途半端には、書き出されるはずなんですが。 どちらにしろ、回答に書いたコードは、ちょっとミスってるので、直します。

a-kuma3さんのコメント
回答に追記、というか修正しました。 それでも、「まとめ」シートに何も書きだされないようであれば、 - SPEED_UP は False - On Error ? の行をコメントアウト して、実行すると、何かエラーが出てるかもしれません。 因みに、こちらで試したのは Excel 2010 です。

a-kuma3さんのコメント
一応、ぼくが試したワークシートも、のっけておきます。 http://firestorage.jp/download/86e2f9a6806ae205e4fd8598e140be64331f25ce

naranara19さんのコメント
ありがとうございました。やはりアクティブ、アクティブでないにかかわらず、何も書込みされませんでした。エラーはでません。SPEED_UP は False⇒これはかわりませんでした。 On Error ? の行をコメントアウト⇒これの意味が私がわからなくて、教えていただけますでしょうか?お手数をおかけしますがよろしくお願いいたします。

a-kuma3さんのコメント
エラー処理をコメントアウトしたコードが、以下になります。 >|vb| 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 ||< 幾つか、質問。 -標準モジュールには、このコード以外に何か書かれてますか? -2015/02/12 17:38:06 のコメントで、こちらで動作確認したシートがありますが、それも動きませんか?

a-kuma3さんのコメント
>> ありがとうございました。やってみたのですが、やはり、表示されないのです。On Error ? の行をコメントアウト←この部分はわかりませんでした。ぜひ教えていただけないでしょうか?エクセルは97-2003ブックで保存しております。 << この質問の補足は、ぼくが 2015/02/13 09:23:19 にコメントした内容を読んでから書いたものでしょうか? 97-2003ブックの形式でも、動きますねえ(動かしているのは、Excel 2010 ですけど)。

naranara19さんのコメント
ありがとうございました。 ・標準モジュールには、このコード以外に何か書かれてますか?⇒はい。たくさんいろいろあります。 2015/02/12 17:38:06 のコメントで、こちらで動作確認したシートがありますが、それも動きませんか?⇒こちらはしっかりと動きました。しかし、 私のシートの方に移植してみても動かないのです。 Macro1 とSummarizeを移植してみましたら、 実行時エラー 457 このキーはすでにこのコレクションの要素に割り当てられています。 が出てしまいます。 もしかして、 実際の商品名が、(15)/りんご 青森県産/N、商品番号が121201101KSとか、151545521S.S 等であることが原因していますでしょうか?商品番号にドットが入ってしまうことなどもあります。スペースが入ることもあります(ただし、場所シートには★と完全に一致した同一の商品名が当然入ります)

a-kuma3さんのコメント
>> Macro1 とSummarizeを移植してみましたら、 実行時エラー 457 このキーはすでにこのコレクションの要素に割り当てられています。 << マクロの最初の方で、「★」シートから、商品名と商品番号の対応表を作っているのですが、商品名に重複があるようです。 商品名が重複していて、商品番号が異なるものがあると、どうにもならないです。 標準モジュールに、他のコードが書いてあるか、と聞いたのは、ぼくが書いたコードでは Option Explicit を書いていないので、元々あったコードに、その指定があるとエラーになるだろうな、と想定してのことでした。 途中まで動いているようなので、それが原因じゃなさそうですね。

a-kuma3さんのコメント
>> 商品名が重複していて、商品番号が異なるものがあると、どうにもならないです。 << +最初に見つけたものを採用する +最後に見つかったものを採用する +エラーで止めて、人間が手で修正する の、どれかで対応するしかありません。

naranara19さんのコメント
商品名が重複していて、商品番号が異なるものがあると、どうにもならないです。 ↑これはないのですけど、何かが反応してしまったのでしょうか。

naranara19さんのコメント
もしよろしければ、直接ファイルを魅せたいのですが、第三者に観られない方法は何かご存知ですか?そのようなことは可能ですか?もちろん、はてなを通して当然ポイントを加算してお支払します。

a-kuma3さんのコメント
「★」シートの商品名 A列で、空白のセルになるまで下向きに探すように作りました。 もしかしたら、商品がない、という意味で、全角の空白やハイフンなどが入ってるセルがあったりしませんか。

a-kuma3さんのコメント
>> もしよろしければ、直接ファイルを魅せたいのですが、第三者に観られない方法は何かご存知ですか?そのようなことは可能ですか? << ぼくが見ちゃっても良いのかな... <tt>:-)</tt> ぼくがフリーメールのアドレスを取って、それに送ってもらい、落ち着いたら、ぼくがそのメールアドレスを捨てる、というのが手っ取り早いですかね。

a-kuma3さんのコメント
あ、いや、運営が内容を見られないものをやり取りすると、規約違反になりかねないんだった... ちょっと考えますね。

a-kuma3さんのコメント
運営には見ることができちゃいますが、ぼくが使った http://firestorage.jp/ みたいなところにファイルを置いて、ポイント送信で 1pt つけて、URL をぼくにおくってもらうのが、一番よさそうです。 ポイント送信は、相手に届く前に運営のチェックが入るので、数日かかりますけど。

a-kuma3さんのコメント
「★」シートに重複があったときに、メッセージボックスを表示して、そこで処理を中断するようにしてみました。 「★」シートのどこに重複があるか、これでわかります。 >|vb| 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 If master.Exists(Name.Value) Then MsgBox "商品名に重複があります。" & vbCrLf & _ r & " 行目。商品名:'" & Name.Value & "'" Exit Sub End If 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 ||<

naranara19さんのコメント
ありがとうございます!少しあとになりますが、必ずお送りします。また、ポイントは必ずお支払しますし逃げることはありませんので、どうかよろしくお願いいたします。大変お手数をおかけして申し訳ございません。

a-kuma3さんのコメント
ポイントは、どうでも良いのですけれど、動かないって、ちょっと気になるので。 というか、あんまりポイントを積んじゃダメです。 ぼくが逃げられなくなっちまう <tt>:-)</tt>

naranara19さんのコメント
ありがとうございました。昨日送信しました!届くまでもう少しお待ちくださいませ。あんまりはつみませんけど、お礼はもらってください。よろしくお願いいたします。

a-kuma3さんのコメント
ついさっき、ポイント付きメッセージが届いたのですが、Firestrage のファイルは、保持期限が過ぎていて削除されてしまってました (´・ω・`) どうしましょうねえ...

a-kuma3さんのコメント
<u>質問と関係ない話</u>ですが、「王様の耳はロバの耳 キャンペーン」を開催中です。 メアドは捨てアカですので、キャンペーン終了時には削除します。 http://profile.hatena.ne.jp/a-kuma3/profile

a-kuma3さんのコメント
回答に書いたコードの一部を修正してみました。 改善されているはずです。 >|vb| 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 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 ||<

naranara19さんのコメント
ありがとうございました!!ばっちりでした。大変感謝します!!!

a-kuma3さんのコメント
ほっとしました <tt>:-)</tt>

a-kuma3さんのコメント
ポイント付きメッセージ、届きました(今度は、一日で届いた)。 ありがたく受け取らせていただきます。

naranara19さんのコメント
a-kuma3さま! 有難うございました!本日実稼働させたのですが、★側シートのセル情報(文字色、セル色、太字など)もまとめシートにコピペして移すことはできますでしょうか?商品名部分だけでかまいません。そちらも変更をお願いすることはできますか?追加作業ですので、当然ポイントは別お支払です。どうかご検討くださいませ。

naranara19さんのコメント
らせんも一緒にうつってかまいません。

a-kuma3さんのコメント
セルの書式をすべてコピーするようにしました。その代わり、処理が随分と遅くなっちゃいました (´・ω・`) >|vb| 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列は幅を広げてください。

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

質問者から

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


関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ