Excel VBA 別ブック複数シートから転記する時、重複チェックして更新or新規登録したい

解決済

回答 1

投稿

  • 評価
  • クリップ 1
  • VIEW 7,353

morikawa0208

score 24

前回は別ブックの複数シートから、条件にあったものを抽出・転記させるところまで
ご回答をいただきました。その節はありがとうございました。
続きでまた詰まってしまいました・・・(頂いたコードから変わっていません・・・)

前提・実現したいこと

作成しているのはマンションの物件管理です。
今前回回答いただいたコードをベースに加工しているのですが、以下の点でつまずいています。
・更新タイミングが複数あるため、マンション名+号室で検索をして、
すでに抽出している内容だったら上書きしたい(登録していない内容だったら最下行に貼付け)
[A列…転記するためのチェックセル→契約済だったら転記する]
[D列…重複チェックのためのセル→マンション号室が同じなら上書き(したい)]

①元ブック(複数シート)でマクロ開始
②DBブックに書き込むための条件検索(以下③と④)
③まず、「契約済」かどうかチェック[A列使用]
④「契約済」の中で、すでに登録されているかチェック[D欄使用]
登録されている…同じ行に上書き(新しくコピーしたほうを貼り付け等)
登録なし…DBブックの最下行、空いている部分に書き込み

該当のソースコード

Sub 書きかけ()
    Dim wbRead As Workbook
    Dim wbOut As Workbook
    Dim shtRead As Worksheet
    Dim shtOut As Worksheet

    Set wbRead = ActiveWorkbook
    Set wbOut = Workbooks("VBAテスト.xlsx")
    Set shtOut = wbOut.Worksheets("TEST")

    Dim rng As Range
    Dim lastRow As Long

    '現在のブック内にあるすべてのシートをループ処理
    For Each shtRead In wbRead.Worksheets
        '対象シート内のA列先頭からA列最終データ行までをループ処理
        For Each rng In shtRead.Range(shtRead.Cells(1, 1), shtRead.Cells(shtRead.Rows.Count, 1).End(xlUp))
            'A列が「契約済」なら、
            If shtRead.Cells(rng.Row, 1) = "契約済" Then
                '読込シートから行コピー
                shtRead.Rows(rng.Row).Copy

                    'D列全体から、検索用を探して、選択する。
                    Dim FoundCell As Range
                    Set FoundCell = Range("D:D").Find(What:="検索用", LookAt:=xlWhole)


                    '【重複ない場合】空白の行に内容を転記
                    If FoundCell Is Nothing Then
                        'DBブックを選択し、一番下の行番号を取得
                        lastRow = shtOut.Cells(shtOut.Rows.Count, 1).End(xlUp).Row + 1
                        '出力シートに値で貼り付け
                        shtOut.Rows(lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False

                    '【重複ある場合】同じ検索用の内容の行に上書きする
                    ElseIf FoundCell = Range("D:D").Find(What:="検索用", LookAt:=xlWhole) Then
                        'その行に貼付け
                        shtOut.Rows(FoundCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False

                    End If

            End If
        Next rng
    Next shtRead
End Sub

試したこと

・重複ある場合の貼付けに「FoundCell.Row」を設定
・Find whatの部分で特定できていないのかと思い、以下のコードを追加
(1004エラーで不可)

Dim KENSAKU as variant
shtRead.Cells(rng.Row,4)=KENSAKU

   Dim FoundCell As Range
   Set FoundCell = Range("D:D").Find(What:=KENSAKU, LookAt:=xlWhole)


FindメソッドのWhat部分をちゃんと指定できればうまくいく気がするんですが、
考え方から間違っているでしょうか・・・
最終的には「契約済みだったら~」の部分が別内容で2~3回繰り返す予定です

何卒よろしくお願いいたします。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

checkベストアンサー

0

確認

やりたいことの確認ですが、

①読込シートのA列が"契約済み"の行をコピー対象行とする
②出力シートのD列に①で見つけた行のD列と同じ値をもつ行があれば、その行に上書きコピーする。
③同じ行がなければ出力シートの最下行にコピーする。

のような動きを期待しているということで大丈夫でしょうか?

指摘

上記の動きでよい場合、いくつか指摘があります。
(まだ提示いただいたコードを実際に動作はさせていませんので、見当違いな点があれば申し訳ありません。)

指摘①

Set FoundCell = Range("D:D").Find(What:=KENSAKU, LookAt:=xlWhole)


の部分ですが、出力シートを指定して検索していません。

Set FoundCell = shtOut.Range("D:D").Find(What:=KENSAKU, LookAt:=xlWhole)


のように対象シートを明示して範囲指定をしてみてはどうでしょうか?

指摘②

Dim KENSAKU as variant
shtRead.Cells(rng.Row,4)=KENSAKU


の部分ですが、宣言したばかりの変数KENSAKUの値を読込シートのセルにセットしています。

Dim KENSAKU as String
KENSAKU = shtRead.Cells(rng.Row,4)


やりたいことはこちらではないでしょうか?
あと、変数KENSAKUはFindで検索対象文字列として使用しますので、Variant型ではなくString型で宣言したほうがいいと思います。

指摘③

'【重複ある場合】同じ検索用の内容の行に上書きする
ElseIf FoundCell = Range("D:D").Find(What:="検索用", LookAt:=xlWhole) Then


の部分ですが、検索自体はすでに行っているので結果判定は`FoundCell is Nothing'がTrueかFalseかだけでいいのではないでしょうか?

単純に

'【重複ある場合】同じ検索用の内容の行に上書きする
Else

でいいような気がします。

まとめると

Sub 書きかけ()
    Dim wbRead As Workbook
    Dim wbOut As Workbook
    Dim shtRead As Worksheet
    Dim shtOut As Worksheet

    Set wbRead = ActiveWorkbook
    Set wbOut = Workbooks("VBAテスト.xlsx")
    Set shtOut = wbOut.Worksheets("TEST")

    Dim rng As Range
    Dim lastRow As Long

    '現在のブック内にあるすべてのシートをループ処理
    For Each shtRead In wbRead.Worksheets
        '対象シート内のA列先頭からA列最終データ行までをループ処理
        For Each rng In shtRead.Range(shtRead.Cells(1, 1), shtRead.Cells(shtRead.Rows.Count, 1).End(xlUp))
            'A列が「契約済」なら、
            If shtRead.Cells(rng.Row, 1) = "契約済" Then
                '読込シートから行コピー
                shtRead.Rows(rng.Row).Copy

                'D列全体から、検索用を探して、選択する。
                'Dim FoundCell As Range
                'Set FoundCell = Range("D:D").Find(What:="検索用", LookAt:=xlWhole)
                Dim KENSAKU as variant
                KENSAKU = shtRead.Cells(rng.Row,4)
                Dim FoundCell As Range
                Set FoundCell = shtOut.Range("D:D").Find(What:=KENSAKU, LookAt:=xlWhole)

                '【重複ない場合】空白の行に内容を転記
                If FoundCell Is Nothing Then
                    'DBブックを選択し、一番下の行番号を取得
                    lastRow = shtOut.Cells(shtOut.Rows.Count, 1).End(xlUp).Row + 1
                    '出力シートに値で貼り付け
                    shtOut.Rows(lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

                '【重複ある場合】同じ検索用の内容の行に上書きする
                'ElseIf FoundCell = Range("D:D").Find(What:="検索用", LookAt:=xlWhole) Then
                Else
                    'その行に貼付け
                    shtOut.Rows(FoundCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False

                End If
            End If
        Next rng
    Next shtRead
End Sub


のような形になるかと思います。
机上コードですのでエラー等あるかもしれませんが、お試しくださいm(__)m

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2016/08/31 12:27

    できました!本当にありがとうございます;;
    ①複数シートある場合に、どのシートで検索するかを指定する必要があるんですね…
    ②代入する場合は、左に代入したい項目
    ③正誤で判断できるIf分はElseで、さらに判断持たせたい場合はElselfを使う

    イメージしていたよりずっとわかりやすく簡潔なコードになりました。
    勉強にもなり、非常に助かりました。
    本文に書いていた「最終的には「契約済みだったら~」の部分が別内容で2~3回繰り返す予定です」といった部分も考えてみるとIf文にOr条件つけるだけでよかったので、
    もっと簡潔に考えるクセをつけようと思います。
    ありがとうございました!

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 90.22%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる
  • トップ
  • VBAに関する質問
  • Excel VBA 別ブック複数シートから転記する時、重複チェックして更新or新規登録したい