2つの条件が一致したら一覧へコピーしたい。左から４番目以降のシート名にコードが入ったシートを全て、

Question

2つの条件が一致したら一覧へコピーしたい。
左から４番目以降のシート名にコードが入ったシートを全て、２番目のシート名「一覧」へコピーしたい。コピーの条件はA列のコードとE列の品名が一致した場合、コードが入ったシートのC列の値を一覧のF列へD列の値をG列へコピーしたい。
どのようなコードを書けばよいか教えてください。

めぐみん_ · Accepted Answer

個人的には

＞For シートNo = 2 To Worksheets.Count
＞Set a_Sht = Sheets("一覧")

この Set a_Sht ~ はループ（For To~Next）の中で何度も実行せず、ループの前で１回だけで良いと思います。
シートの選択が固定されてますしね。
SheetsとWorksheetsは厳密には違いますので（今はあまり意識して使われないかもですが）、Worksheetsに統一が宜しいのでは？

Set a_Sht = Worksheets("一覧") '←ここ
For シートNo = 2 To Worksheets.Count
'★Set a_Sht = Sheets("一覧")

あ、でもシートをSelectとかしているってなら上記はまずいかもですが、その先が不明なので・・・

tatsumaru77 · Answer

No3の方のアドバイスに従い、Dictionaryオブジェクトをつかってみました。

Public Sub 個数梱包設定()
    Dim ws1 As Worksheet    '一覧シート
    Dim ws2 As Worksheet    '左から4番目以降のシート
    Dim maxrow1 As Long     '一覧シート最大行
    Dim maxrow2 As Long     '左から4番目以降のシートの最大行
    Dim row1 As Long        '一覧シート行番号
    Dim row2 As Long        '左から4番目以降の行番号
    Dim dicT As Object      'Dictionary キー：コード＋品名 値：一覧シートの行番号
    Dim key As String       'Dictionaryのキー
    Dim i As Long
    Set dicT = CreateObject("Scripting.Dictionary") ' Dictionay定義
    Set ws1 = Worksheets("一覧")
    maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row 'A列 最終行を求める
    'Dictionaryを作成
    For row1 = 3 To maxrow1
        key = ws1.Cells(row1, "A").Value & "|" & ws1.Cells(row1, "E").Value
        dicT(key) = row1
    Next
    '左から4番目以降のシートを右へ順番に処理する
    For i = 4 To Worksheets.Count
        Set ws2 = Worksheets(i)
        maxrow2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row 'A列 最終行を求める
        For row2 = 4 To maxrow2
            key = ws2.Cells(row2, "A").Value & "|" & ws2.Cells(row2, "B").Value
            'コード＋品名が一覧シート内にあるなら設定する
            If dicT.exists(key) = True Then
                row1 = dicT(key)
                ws1.Cells(row1, "F").Value = ws2.Cells(row2, "C").Value     '個数設定
                ws1.Cells(row1, "G").Value = ws2.Cells(row2, "D").Value     '梱包設定
            End If
        Next
    Next
    MsgBox ("完了")
End Sub

めぐみん_ · Answer

＞4) 4番目のシートG列の値を

Ｄ列ではなくて？
それと画像と実際のセル開始位置（シート名：”一覧”）は違うのですか？

多分Dictionaryオブジェクトを使うと楽だと思いますよ。
まだ未経験であれば最初はきついかもですけど、過去質で Dictionary を検索しExcelの質問を探し出してみるとかですかね。
と同時にネット検索をして基本的な使い方『 VBA Dictionaryオブジェクト 』を知ることが先かな。

銀鱗 · Answer

面倒なんでワークシート名を全部取得すれば良い。
そのあと、それを使って処理をする。

・・・

Dim i As Long
　Dim SheetsCnt As Long

'これでワークシートの数を取得できる。
　'ThisWorkbook.Sheets.Count

'ここから全てのワークシート名を取得する。
　SheetsCnt = ThisWorkbook.Sheets.Count
　For i = 1 To SheetsCnt
　　Debug.Print Sheets(i).Name
　　'シート名をセルの上に表示する。
　　'Cells(i, 1).Value = Sheets(i).Name
　Next

・・・

こんな感じ。
取得したシート名をセルの上に表示するなら、コメントにした

'Cells(i, 1).Value = Sheets(i).Name

これをコメントアウトしてください。

銀鱗 · Answer

まずは選択するための条件を「箇条書き」にしてみましょう。

そのうえで、どの順番に条件を比較すれば良いかを決め、

１、その順番に対象を比較する。
　２、条件が満たされたらコピーする。
　３、比較対象が他にあれば１へ戻り、無ければ終了。

こんなコードにすればいい。

とりあえず「箇条書き」から始めてみましょう。

・・・余談・・・

ここは「代わりに作ってください」と作業依頼する場所ではありません。
自力で解決できるようになるためのアドバイスをもらう場所です。
もしも代わりに作ってもらうことを希望しているのであれば、他の有料サイトを利用するようにしましょう。

2つの条件が一致したら一覧へコピーしたい。 左から４番目以降のシート名にコードが入ったシートを全て、

個人的には

No3の方のアドバイスに従い、Dictionaryオブジェクトをつかってみました。

＞4) 4番目のシートG列の値を

面倒なんでワークシート名を全部取得すれば良い。

まずは選択するための条件を「箇条書き」にしてみましょう。

似たような質問が見つかりました

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

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

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

2つの条件が一致したら一覧へコピーしたい。左から４番目以降のシート名にコードが入ったシートを全て、