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

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

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

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

Q&A

解決済

2回答

381閲覧

異なるシートからすべて転記

hajihaji

総合スコア18

VBA

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

0グッド

0クリップ

投稿2018/08/22 02:02

前提・実現したいこと

VBA初心者です。
データベースを随時更新していくコードを作っています。
過去データSheet1に最新データSheet2からデータを追記していくものを想定しています。
Sheet1の情報がSheet2に存在するかを検索し、存在しない場合に新しいデータと見做し、
シート間で差異データをSheet2からSheet1へ転記したいのですが、
該当する行が複数ある場合に、一行しか転記しない状況です。
例(A列1行から10行が同じデータの場合、1行目しか転記しない)
これをすべて転記するにはどうしたらいいでしょうか。
よろしくお願いします。

発生している問題・エラーメッセージ

エラーメッセージ

該当のソースコード

Sub 検索転記()
Dim sh1 As Worksheet
Dim sh2 As Worksheet

Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")

R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
R2 = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row

n = R1 + 1
For i = 1 To R2

Set x = sh1.Columns("A").Find(What:=sh2.Cells(i, "A"), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

If x Is Nothing Then

sh1.Cells(n, "A") = sh2.Cells(i, "A")
sh1.Cells(n, "B") = sh2.Cells(i, "B")

n = n + 1

End If

Next i
End Sub

試したこと

検索条件を2つに設定してもれなく、だぶりなくデータを更新するように試みたのですがうまくいきません。

補足情報(FW/ツールのバージョンなど)

ここにより詳細な情報を記載してください。

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

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

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

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

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

m.ts10806

2018/08/22 02:20

プログラムコード(およびエラーメッセージ)は質問内容としては最も重要な部分であるため、見やすくしていただけると助かります。<code>ボタン押下→「コード」部分にコードを貼り付け→「ここに言語を入力」に対象言語名記入(エラーメッセージの場合は不要)の手順で「コードハイライト化」してください。(質問編集画面ではリアルタイムでプレビューが表示されるので見ながら調整してください)
m.ts10806

2018/08/22 02:20

質問編集画面タイトル横にある「初心者アイコン」をご活用ください。「初心者」と質問で書くよりも伝わりますし、質問一覧に表示されるのでわかりやすくなります。
guest

回答2

0

原因は、1件目の該当データがsheet1に追記されると、その該当データの「A列側の値」(以下、"項目名"と呼ぶことにします)は、sheet1のA列に含まれることになります。
そして、2件目以降の該当データの項目名は、1件目の該当データの項目名と同じですから、既にA列に存在することとなり、追加されません。

この問題は、探す対象範囲をA列全体(sh1.Columns("A"))している事が原因です。
探す範囲を過去データ(元々sheet1に入っていたデータ)が入っている範囲に絞れば、新たに追加したデータが検索に引っかからなくなるので、すべての該当データが追加されるはずです。

具体的には、

Set x = sh1.Columns("A").Find(What:=sh2.Cells(i, "A"), LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

Set x = sh1.Range(sh1.cells(1,"A"),sh1.cells(R1,"A")).Find(What:=sh2.Cells(i, "A"), LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

に修正してみてください。

== 追記 「現状ではA列のセルの一致だけで新規データかどうかを判断しているが、A列のセルとB列のセルの両方が一致しているものは新規データに追加しないようにしたい」旨のコメントが質問者からあったので、それに対する回答を追加します。 ==

B列のセルでも一致するかどうかを判断すれば良いのですから、

If x Is Nothing Then sh1.Cells(n, "A") = sh2.Cells(i, "A") sh1.Cells(n, "B") = sh2.Cells(i, "B") n = n + 1 End If

の部分を

If x Is Nothing Then // 過去データのA列に一致するものがない => 新規データに追加する。 sh1.Cells(n, "A") = sh2.Cells(i, "A") sh1.Cells(n, "B") = sh2.Cells(i, "B") n = n + 1 ElseIf sh1.Cells(n,"B") <> x.Offset(0,1) Then // B列のセルの内容が一致しない => 新規データに追加する。(x.offset(0,1)でxセルの右側のセルを指定したことになる) sh1.Cells(n, "A") = sh2.Cells(i, "A") sh1.Cells(n, "B") = sh2.Cells(i, "B") n = n + 1 End If // 上記の2条件に合わないものは、新規データに追加しない

のように書き換えれば良いと思います。

投稿2018/08/22 02:36

編集2018/08/23 04:31
coco_bauer

総合スコア6915

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

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

hajihaji

2018/08/22 03:26

早々のご回答ありがとうございます。 このようなやり方はわたしでは思いつきませんでした。 感謝いたします。
hajihaji

2018/08/22 03:27

ちなみに複数の条件(A列とB列)でよりダブリがないように抽出するためになにかいい方法がありましたらご教示のほどよろしくお願いいたします。
coco_bauer

2018/08/22 05:01

「よりダブリがない」の判断基準がわかりません。A列、B列のペアが一致したものだけ追加しない(「リンゴ、青森」、「リンゴ、福島」、「もも、福島」が過去データに含まれていた場合、「リンゴ、福島」は追加しないが、「もも、青森」「ブドウ、福島」は追加する)という事でしょうか?
hajihaji

2018/08/23 02:43

はい。そうです。 Sheet1に(「リンゴ、福島」) Sheet2に(「リンゴ、青森」、「リンゴ、福島」、「もも、福島」)の場合、 Sheet2よりSheet1に(「リンゴ、青森」、「もも、福島」)を追加したいということです。 先日のコードだけだとリンゴとももだけで判別してしまい(「もも、福島」)だけが追加されるためです。 どうぞよろしくお願いいたします。
hajihaji

2018/08/27 06:11

ご回答感謝申し上げます。
guest

0

ベストアンサー

見つけたタイミングで転記してしまうと、次に同じデータがあった場合に存在していることになってしまうので、対象外になってしまうのでしょう。
処理を2回に分ける方がスムーズに行くと思います。
最初に転記対象の情報収集、次に情報収集したものを転記する。
コードを書いてみましたが動作未確認です。参考まで。

VBA

1Sub 検索転記() 2 Dim sh1 As Worksheet 3 Dim sh2 As Worksheet 4 Dim idx As Collection 5 6 Set sh1 = Worksheets("Sheet1") 7 Set sh2 = Worksheets("Sheet2") 8 Set idx = New Collection 9 10 R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row 11 R2 = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row 12 13 ' 情報収集 14 For i = 1 To R2 15 Set x = sh1.Columns("A").Find(What:=sh2.Cells(i, "A"), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) 16 If x Is Nothing Then 17 idx.Add i 18 End If 19 Next i 20 21 ' 対象分を転記 22 n = R1 + 1 23 For Each i In idx 24 sh1.Cells(n, "A") = sh2.Cells(i, "A") 25 sh1.Cells(n, "B") = sh2.Cells(i, "B") 26 n = n + 1 27 Next i 28End Sub 29

投稿2018/08/22 02:22

ttyp03

総合スコア16996

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

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

hajihaji

2018/08/22 02:54

早々のご回答ありがとうございます。 うまくいきました。 ちなみに複数の条件(A列とB列)でよりダブリがないように抽出するためになにかいい方法がありましたらご教示のほどよろしくお願いいたします。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

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

ただいまの回答率
85.50%

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

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

質問する

関連した質問