Excelでデータの抽出＆別シート転記をマクロで行いたい(VBA)

Question

はじめまして、Excel2010を使用しています。

添付画像のように1つのブックにリストと注文表という2つのシートがあり、
注文表B列の登録番号と一致するデータをリストから抽出して別シートに転記し、
注文表のA列(受注日)・B列(登録番号)・リストのG列(商品名)・H列(個数)・注文表のC列
(注文数)・個数に注文数をかけた数量を入れる列の6列構成の表にする作業をしています。

リストのデータは毎週連番で新規追加され、現在は10000行超のデータが入っていますが、
空白セルが多くフィルターも使えません。
前任者はリストC列を登録番号で検索＆コピペを繰り返していたようですが
日によっては件数が大量になることもあり全て手作業はキツイです…。

リストの空白行を削除＆C列の内容を空白セル分下方向にコピーするマクロを組みましたが
問題はC11&C12セルのような箇所(全データの1/3程度がこの状態)です。
配送先が異なるだけで注文内容は同一なので、注文表の登録番号が1002でも1003でも
G11:H16のデータを抽出したいのですがアイデアが浮かびません。
内容のチェックに時間を割きたいので、データの抽出はなるべく自動化したいです。
良い方法をご教示いただけますでしょうか？よろしくお願いいたします。

tatsu99 · Accepted Answer

標準モジュールへ登録してください。（手配リストも作成しておいてください。ないとエラーになります。）文字数オーバーなので2回に分けます。（1回位目） --------------------------------------- Option Explicit Dim sh1 As Worksheet Dim sh2 As Worksheet Dim sh3 As Worksheet Dim dicT As Object '登録番号の出現行を保持 Dim dicS As Object '登録番号に一致する商品の開始行を保持（|で区切って複数もつ） Dim dicE As Object '登録番号に一致する商品の終了行を保持（|で区切って複数もつ） Dim errmsg As String Public Sub 手配書作成() Set sh1 = Worksheets("リスト") Set sh2 = Worksheets("注文表") Set sh3 = Worksheets("手配リスト") Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義 Set dicS = CreateObject("Scripting.Dictionary") ' 連想配列の定義 Set dicE = CreateObject("Scripting.Dictionary") ' 連想配列の定義 errmsg = "" 'リストを読み込み登録番号の連想配列を作成する Call GetNumber '注文表を読み込み手配リストを作成 Call Tehai '重複番号のエラーを表示 If errmsg <> "" Then MsgBox (errmsg) End If MsgBox ("処理完了") End Sub '手配リスト作成 Private Sub Tehai() Dim maxrow As Long Dim row1 As Long Dim row2 As Long Dim row3 As Long Dim i As Long Dim key As Variant Dim srows As Variant Dim erows As Variant '手配リスト２行目以降をクリア maxrow = sh3.Cells(sh1.Rows.Count, "A").End(xlUp).row sh3.Range("A2:F" & maxrow).Value = "" row3 = 2 maxrow = sh2.Cells(sh1.Rows.Count, "A").End(xlUp).row For row2 = 2 To maxrow '2行～最後の行まで繰り返す key = sh2.Cells(row2, "B").Value If dicT.exists(key) = False Then MsgBox ("注文表の登録番号がリストになし　行番号=" & row2 & "　登録番号=" & key) sh2.Activate sh2.Cells(row2, "B").Select End End If '登録番号に対応する商品の開始行と終了行を取得 srows = Split(dicS(key), "|") erows = Split(dicE(key), "|") For i = 0 To UBound(srows) '複数の登録番号分繰り返す For row1 = CLng(srows(i)) To CLng(erows(i)) '商品の数分繰り返す sh3.Cells(row3, "A").Value = sh2.Cells(row2, "A").Value '受注日 sh3.Cells(row3, "B").Value = sh2.Cells(row2, "B").Value '登録番号 sh3.Cells(row3, "C").Value = sh1.Cells(row1, "G").Value '商品名 sh3.Cells(row3, "D").Value = sh1.Cells(row1, "H").Value '個数 sh3.Cells(row3, "E").Value = sh2.Cells(row2, "C").Value '注文数 sh3.Cells(row3, "F").Value = sh3.Cells(row3, "D").Value * sh3.Cells(row3, "E").Value '合計(個数×注文数) row3 = row3 + 1 Next Next Next End Sub '登録番号取得 Private Sub GetNumber() Dim maxrow As Long Dim maxrow2 As Long Dim row As Long Dim srow As Long Dim erow As Long srow = 0 'C列とF列の大きい方を最終行番号とする maxrow = sh1.Cells(sh1.Rows.Count, "F").End(xlUp).row maxrow2 = sh1.Cells(sh1.Rows.Count, "C").End(xlUp).row If maxrow2 > maxrow Then maxrow = maxrow2 For row = 2 To maxrow '登録番号の開始位置検知 If sh1.Cells(row, "A").Value <> "" Then Call CheckRow(row, 2, 8) '行チェック Call makeDict(srow, row - 1) '登録番号の辞書登録（空白行がない場合の保険） srow = row End If '登録番号の終了位置検知 If sh1.Cells(row, "C").Value = "" And sh1.Cells(row, "F").Value = "" Then Call makeDict(srow, row - 1) '登録番号の辞書登録 srow = 0 End If Next Call makeDict(srow, row - 1) '（空白行がない場合の保険） End Sub

ママチャリ · Answer

横から失礼します。こんなプログラムは、いかがでしょうか？
このプログラムは、リストの各ブロックが空白行で区切られていることに着目して作られています。よって、リストの見出し行と最初のブロックの間にも空白行が必要です。
それから、登録番号の重複（または無い）チェックはしていませんので、注文表のD列に次の関数を設定して事前にデータの不備を確認をしておいてください。
さらに、手配リストの「合計」欄は計算を省略しています。sunuko05さんの方で組み込んでみて下さい。

【注文表のD２セル】=COUNTIF(リスト!C:C,B2)
上記式の答えが、ゼロの場合は「無い」。1より大きい場合は「重複」です。

Sub sample()
    Dim i As Long
    Dim j As Long
    Dim r As Long
    Dim myRng As Range
    Dim wsリ As Worksheet
    Dim ws注 As Worksheet
    Dim ws手 As Worksheet
    Set wsリ = Sheets("リスト")
    Set ws注 = Sheets("注文表")
    Set ws手 = Sheets("手配リスト")
    ws手.Rows("2:" & Rows.Count).Delete
    For i = 2 To ws注.Cells(Rows.Count, "A").End(xlUp).Row
        j = ws手.Cells(Rows.Count, "C").End(xlUp).Row + 1
        Set myRng = wsリ.Range("C:C").Find(ws注.Cells(i, "B"), _
            LookIn:=xlValues, LookAt:=xlWhole).CurrentRegion.Columns(7)
        myRng.Resize(, 2).Copy Destination:=ws手.Cells(j, "C")
        r = ws手.Cells(Rows.Count, "C").End(xlUp).Row - j + 1
        ws注.Cells(i, "A").Copy (ws手.Cells(j, "A").Resize(r))
        ws注.Cells(i, "B").Copy (ws手.Cells(j, "B").Resize(r))
        ws注.Cells(i, "C").Copy (ws手.Cells(j, "E").Resize(r))
    Next i
End Sub

tatsu99 · Answer

たびたびすみません。
No7で
Call CheckRow(row, 6, 8) '行チェック・・・削除①
この行を削除と述べましたが、
削除してしまうと
No8のように２２行のF列に半角又は全角のスペースなどがある場合、その行を商品のある行として扱ってしまします。
そのため、正しい結果が得られません。
よって、No7は行わないでください。（削除しないでください）

まずは、No８のような事象が起こってないか確認ください。

tatsu99 · Answer

すみません。念のため確認ですが、停止時にセルを選択しますが、G22（空白）で停止していますか。
その時に、F21が空白でない可能性があります。F21に空白のようにみえるごみデータが格納されていませんでしょうか。
チェックは、F列が空白でないなら、G列,H列も空白でないことを確認しています。
なお、空白という言葉を使っていますが、正確には""(長さ０の文字列です)
F21に半角スペース、全角スペース、タブなどが、入っていませんでしょうか。

tatsu99 · Answer

>追加画像の21～22行(登録番号1006・1007)のようなデータの場合に
>7列目が空白→エラー終了となってしまいます。
>F～H列の商品名欄が空白(商品の数が1品のみ)の場合もあり得るので
>少し手をいれさせていただきたいのですが、お恥ずかしながら自力でコードの修正が出来ません(泣

うーむ。こちらでは、そのケースの場合、エラーにしていません。
なにか、環境が違うのかも知れません。
とりあえず、以下の削除①の箇所をコメントアウトしてください。（1行だけです）
それで、実行してどうなりますか。
--------------------------------------------
'登録番号の辞書登録
Private Sub makeDict(ByVal srow As Long, ByVal erow As Long)
    Dim row As Long
    Dim key As Variant
    Dim r_erow As Long  '商品の最後の行
    If srow = 0 Then Exit Sub
    For row = srow To erow
        If sh1.Cells(row, "F").Value = "" Then
            Exit For
        End If
        r_erow = row
        Call CheckRow(row, 6, 8) '行チェック・・・削除①
    Next

tatsu99 · Answer

2回目です。
----------------------------
'登録番号の辞書登録
Private Sub makeDict(ByVal srow As Long, ByVal erow As Long)
    Dim row As Long
    Dim key As Variant
    Dim r_erow As Long  '商品の最後の行
    If srow = 0 Then Exit Sub
    For row = srow To erow
        If sh1.Cells(row, "F").Value = "" Then
            Exit For
        End If
        r_erow = row
        Call CheckRow(row, 6, 8) '行チェック
    Next
    For row = srow To erow
        If sh1.Cells(row, "C").Value <> "" Then
            key = sh1.Cells(row, "C").Value
            Call CheckRow(row, 4, 5)  '行チェック
            If dicT.exists(key) = True Then
                If errmsg = "" Then errmsg = "登録番号重複" & vbLf
                errmsg = errmsg & "登録番号=" & key & "　基準行=" & dicT(key) & "　重複行=" & row & vbLf
                dicS(key) = dicS(key) & "|" & srow
                dicE(key) = dicE(key) & "|" & r_erow
            Else
                dicT(key) = row
                dicS(key) = srow
                dicE(key) = r_erow
            End If
        End If
    Next
End Sub
'行チェック
Private Sub CheckRow(ByVal row As Long, ByVal scol As Long, ByVal ecol As Long)
    Dim col As Long
    For col = scol To ecol
        If sh1.Cells(row, col) = "" Then
            MsgBox ("リストの" & row & "行が不正　" & col & "列が空白です")
            sh1.Activate
            sh1.Cells(row, col).Select
            End
        End If
    Next
End Sub
ｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰ
以上です。不明点は補足ください。

tatsu99 · Answer

No2です。
追加の確認です。
手配リストに合計を設定する場合は、リストの個数と注文表の注文数をかけた結果を設定しますが、
リストの個数と注文表の注文数は必ず数値が設定されている前提で良いですか。
それとも、リストの個数、注文表の注文数の何れかに”A”等の誤ったデータが設定されていることも考慮したほうが良いのでしょうか。
もし、チェックをするなら、そのようなケースの場合は、エラーメッセージ表示後、処理を打ち切ります。

tatsu99 · Answer

No2です。
念の為、確認ですが、
マクロで作成したいのは、手配リストであって、
望ましいリスト（登録番号を分けて作成したリスト）ではないですね。
注文表とリストから手配リストを作るつもりです。望ましいリストは作成しません。

tatsu99 · Answer

なんとなく状況はわかりました。更に追加で補足要求です。
１）注文表を基準にして、手配リストを作るということで良いでしょうか。
（リストを基準にして手配リストは作らない）
具体的には、以下のようになります。
①注文表の2行目の受注日、登録番号、注文数を取得する。
②この登録番号に一致する商品名と個数をリストから取得する。
（登録番号は複数あり）
③この受注日、登録番号、商品名、個数、注文数、合計を手配リストへ出力する。
（複数行になる）

④同様にして、上記の①～③の作業を注文表の３行から最後の行まで行う。

２）リスト内に出現する登録番号は必ず１つであるという前提で良いでしょうか。
例えば、C12が1003ですが、その場合、C3も1003となることはない。
C列に同じ登録番号が２つ以上存在した場合は、エラーとして良いですか。

３）データのチェックの為ですが、
C12に1003のように登録番号が存在した場合、その行のD列、E列は必ずデータが設定されている
という前提で良いですか。
C列に登録番号があって、その行のD列、E列が空白の場合は、エラーとして良いですか。

tatsu99 · Answer

補足要求です。
１）
>添付画像のように1つのブックにリストと注文表という2つのシートがあり、
>注文表B列の登録番号と一致するデータをリストから抽出して別シートに転記し、
>注文表のA列(受注日)・B列(登録番号)・リストのG列(商品名)・H列(個数)・注文表のC列
>(注文数)・個数に注文数をかけた数量を入れる列の6列構成の表にする作業をしています。

上記の例で示されるリストと注文表から作成したい別シートの画像も添付してください。（シート名も提示してください）

２）「リストでA列～E列が空白の行は、その上の行の内容と同じである」という前提で良いでしょうか。
例えば、１３行は、
A列＝17/1/1
B列＝高橋
C列＝1003
D列＝小型ｰ1003
E列＝名古屋店
であるとみなしてよいのでしょうか。

Excelでデータの抽出＆別シート転記をマクロで行いたい(VBA)

標準モジュールへ登録してください。

横から失礼します。

たびたびすみません。

すみません。

>追加画像の21～22行(登録番号1006・1007)のようなデータの場合に

2回目です。

No2です。

No2です。

なんとなく状況はわかりました。

補足要求です。

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング