質問をすることでしか得られない、回答やアドバイスがある。

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

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

1回答

16152閲覧

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

morikawa0208

総合スコア27

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

1クリップ

投稿2016/08/30 05:29

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

###前提・実現したいこと

作成しているのはマンションの物件管理です。
今前回回答いただいたコードをベースに加工しているのですが、以下の点でつまずいています。
・更新タイミングが複数あるため、マンション名+号室で検索をして、
すでに抽出している内容だったら上書きしたい(登録していない内容だったら最下行に貼付け)
[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回繰り返す予定です

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

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

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

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

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答1

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 00:43

編集2016/08/31 00:46
jawa

総合スコア3013

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

morikawa0208

2016/08/31 03:27

できました!本当にありがとうございます;; ①複数シートある場合に、どのシートで検索するかを指定する必要があるんですね… ②代入する場合は、左に代入したい項目 ③正誤で判断できるIf分はElseで、さらに判断持たせたい場合はElselfを使う イメージしていたよりずっとわかりやすく簡潔なコードになりました。 勉強にもなり、非常に助かりました。 本文に書いていた「最終的には「契約済みだったら~」の部分が別内容で2~3回繰り返す予定です」といった部分も考えてみるとIf文にOr条件つけるだけでよかったので、 もっと簡潔に考えるクセをつけようと思います。 ありがとうございました!
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

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

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問