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

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

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

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

Q&A

解決済

1回答

4500閲覧

【VBA】条件が一致したらコピーして別シートに値を貼り付けたい

koburon

総合スコア30

VBA

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

0グッド

0クリップ

投稿2023/01/12 08:26

編集2023/01/13 02:57

前提

VBAで任意の日付に異動した社員リストを作成するマクロを作っています。

使用するシートは以下の3枚です。

  • 異動DB
  • 現在の社員名簿
  • 異動者リスト

「異動DB」
イメージ説明

「現在の社員名簿」※氏名、氏名カナは個人情報につき伏せています
イメージ説明

「異動者リスト」
イメージ説明

「現在の社員名簿」と「異動者リスト」の表は全く同じ項目と列幅、フォントの大きさ等に調整しているので、貼り付けは値のみとします。

実現したいこと

ボタンをクリックするとダイアログが開き、任意の日付を入力します。
「OK」をクリックすると、「異動DB」でその日付に異動した社員をオートフィルタで抽出し、「異動者リスト」のA列に該当する社員の社員番号を貼り付けます。
さらに、「現在の社員名簿」のA列と「異動者リスト」のA列が一致した場合のみ、「現在の社員名簿」のA列~EN列をコピーして「異動者リスト」に貼り付けを行い、最終行までこれを繰り返すようなコードにしたいです。

該当のソースコード

一部、不要な変数や表現が含まれているかもしれないです。

VBA

1Sub idou() 2'異動者リストを作成する 3 4 '任意の日の異動者を抽出する 5 Application.ScreenUpdating = False 6 7 Dim d As Date 8 Dim dval As String 9 Dim flag As Boolean 10 Dim Target_date As Range 11 Dim Target_no As Range 12 Dim i As Long 13 Dim lastRow As Long 14 Dim cnt As Long 15 Dim wS As Worksheet 16 17 18 flag = False 19 20 Do While flag = False 21 dval = InputBox("基準日を入力(記入例:1900/1/1)") 22 If StrPtr(dval) = 0 Then 23 'キャンセル又は右上の×をクリックした場合 24 Exit Sub 25 ElseIf dval = "" Then 26 'なにも入力しないでOKをクリックした場合 27 MsgBox ("何も入力されていません") 28 Else 29 '上記以外 30 '入力日付は正しいものとする 31 '(必要があれば入力日付のチェックを行い、エラーなら再入力する) 32 d = CDate(dval) 33 flag = True 34 End If 35 Loop 36 37 '抽出する日付を記入する 38 Worksheets("異動DB").Activate 39 Range("R1") = d 40 41 'データの書式を「標準」にして日付データをシリアル値にする 42 Range("R1").NumberFormatLocal = "標準" 43 44 'B列のデータを変数として取得する 45 Set Target_date = Range(Range("B1"), Cells(Rows.Count, 1).End(xlUp)) 46 47 'データの書式を「標準」にしてB列をシリアル値にする 48 Target_date.NumberFormatLocal = "標準" 49 50 'オートフィルタでセルA1に入力された区分データを抽出する 51 '(抽出する区分は2) 52 Range("A1").AutoFilter Field:=1, Criteria1:="2" 53 54 'オートフィルタでセルR1に入力された日付で抽出する 55 Range("A1").AutoFilter 2, Range("R1") 56 57 'データの書式を「日付」に戻す 58 Range("R1").NumberFormatLocal = "yyyy/mm/dd" 59 60 '抽出した「社員番号」をコピーして貼り付け 61 Range("D1").Offset(1, 0). _ 62 Resize(Range("D1").CurrentRegion.Rows.Count - 1).Copy Sheets("異動者リスト").Range("A3") 63 64 '異動者リストに移動 65 Worksheets("異動者リスト").Activate 66 Set wS = Worksheets("異動者リスト") 67 68 '最終行を取得する 69 lastRow = wS.Cells(Rows.Count, 1).End(xlUp).Row 70 71 '異動者リストに社員情報をコピーする 72 If lastRow > 3 Then 73 Range(wS.Cells(3, "B"), wS.Cells(lastRow, "EN")).ClearContents 74 End If 75 cnt = 2 76 With Worksheets("現在の社員名簿") 77 For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 78 If .Cells(i, "A") = wS.Range("B3") And .Cells(i, "B") = wS.Range("C3") Then 79 cnt = cnt + 1 80 wS.Cells(cnt, "B").Resize(, 4).Value = .Cells(i, "A").Resize(, 4).Value 81 End If 82 Next i 83 End With 84 85 'リストに掛け線を追加する 86 Worksheets("異動者リスト").Range("A2:en" & lastRow).Borders.LineStyle = xlContinuous 87 88 '先頭にタイトルをつける 89 Worksheets("異動者リスト").Range("A1") = d & "異動者リスト" 90 91 Application.ScreenUpdating = True 92 93End Sub

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

抽出した「社員番号」を貼り付けるところまでは問題なく動作したのですが、B列から右部分の社員名簿情報が貼りつかない状態です。下記の部分がうまくいかない原因と考えられます。

VBA

1'異動者リストに社員情報をコピーする 2 If lastRow > 3 Then 3 Range(wS.Cells(3, "B"), wS.Cells(lastRow, "EN")).ClearContents 4 End If 5 cnt = 2 6 With Worksheets("現在の社員名簿") 7 For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 8 If .Cells(i, "A") = wS.Range("B3") And .Cells(i, "B") = wS.Range("C3") Then 9 cnt = cnt + 1 10 wS.Cells(cnt, "B").Resize(, 4).Value = .Cells(i, "A").Resize(, 4).Value 11 End If 12 Next i 13 End With

試したこと

下記のURLリンクで参考になりそうなサンプルコードを見つけたので、これをベースとしています。

VBA

1Sub Sample1() 2Dim i As Long, lastRow As Long 3Dim cnt As Long, wS As Worksheet 4Set wS = Worksheets("Sheet2") 5lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row 6If lastRow > 3 Then 7Range(wS.Cells(6, "B"), wS.Cells(lastRow, "E")).ClearContents 8End If 9cnt = 5 10With Worksheets("Sheet1") 11For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 12If .Cells(i, "A") = wS.Range("B2") And .Cells(i, "B") = wS.Range("C2") Then 13cnt = cnt + 1 14wS.Cells(cnt, "B").Resize(, 4).Value = .Cells(i, "A").Resize(, 4).Value 15End If 16Next i 17End With 18End Sub

こちらのマクロに合うように数値や変数を書き直したつもりなのですが、社員番号が貼りつくだけで、右の社員情報が貼りつかない状況です。
原因やうまくデータを貼り付ける方法がありましたらご教示いただければと思います。
また、コードも長いため、標準モジュールを追加してコードを分ける等してスリムにする必要があるかと思いますが、ひとまず1つのSub プロシージャで記述していただければ幸いです。
よろしくお願いいたします。

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

PC:Windows11
ソフト:Microsoft365 Excel
参考URL:
vba 2つの条件が一致したらコピーして別シートに値のみ貼り付け
社員名簿を作る ~その1~

追記

いただいたコメントを参考に、変数などを書き換えてコードを修正しました。

VBA

1Sub idou() 2'異動者リストを作成する 3 4 '任意の日の異動者を抽出する 5 Application.ScreenUpdating = False 6 7 Dim d As Date 8 Dim dval As String 9 Dim flag As Boolean 10 Dim Target As Range 11 Dim i As Long 12 Dim cnt As Long 13 Dim LastRow As Long 14 Dim LastClm As Long 15 Dim strDateFormat As String 16 Dim wS1 As Worksheet 17 Dim wS2 As Worksheet 18 Dim wS3 As Worksheet 19 20 flag = False 21 22 Do While flag = False 23 dval = InputBox("基準日を入力(記入例:1900/1/1)") 24 If StrPtr(dval) = 0 Then 25 'キャンセル又は右上の×をクリックした場合 26 Exit Sub 27 ElseIf dval = "" Then 28 'なにも入力しないでOKをクリックした場合 29 MsgBox ("何も入力されていません") 30 Else 31 '上記以外 32 '入力日付は正しいものとする 33 '(必要があれば入力日付のチェックを行い、エラーなら再入力する) 34 d = CDate(dval) 35 flag = True 36 End If 37 Loop 38 39 'ワークシートを変数で宣言 40 Set wS1 = Worksheets("異動DB") 41 Set wS2 = Worksheets("異動者リスト") 42 Set wS3 = Worksheets("現在の社員名簿") 43 44 '抽出する日付を記入 45 wS1.Activate 46 wS1.Range("R1") = d 47 48 'B列のデータを変数として取得 49 Set Target = Range(Range("B1"), Cells(Rows.Count, 1).End(xlUp)) 50 51 'オートフィルタでセルA1に入力された区分データを抽出 52 '(抽出する区分は2) 53 Range("A1").AutoFilter Field:=1, Criteria1:="2" 54 55 'オートフィルタでセルR1に入力された日付で抽出 56 Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat) 57 58 '抽出した「社員番号」をコピーして貼り付け 59 Range("D1").Offset(1, 0). _ 60 Resize(Range("D1").CurrentRegion.Rows.Count - 1).Copy wS2.Range("A3") 61 62 '異動者リストに移動 63 wS2.Activate 64 65 '最終行 66 LastRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row 67 68 '最終列 69 LastClm = wS2.Cells(2, Columns.Count).End(xlToLeft).Column 70 71 '異動者リストで社員番号より右をクリア 72 If LastRow > 2 Then 73 Range(wS2.Cells(3, "B"), wS2.Cells(LastRow, LastClm)).ClearContents 74 End If 75 76 '異動者リストに社員情報をコピー 77 With wS3 78 For i = 3 To LastRow 79 For cnt = 3 To LastRow 80 If wS3.Cells(i, "A").Value = wS2.Range(cnt, 1).Value Then 81 82 wS2.Cells(cnt, 2).Resize(, LastClm -1 ).Value = wS3.Cells(i, 2).Resize(, LastClm -1 ).Value 83 84 End If 85 Next cnt 86 Next i 87 End With 88 89 'リストに掛け線を追加 90 wS2.Range("A2:en" & LastRow).Borders.LineStyle = xlContinuous 91 92 '先頭にタイトルをつける 93 wS2.Range("A1") = d & "異動者リスト" 94 95 Application.ScreenUpdating = True 96 97End Sub

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

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

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

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

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

pig_vba

2023/01/13 01:01 編集

参考元はB2:C2に抽出用データが登録されていますが異動者リストにはありません。また、先頭一名しか比較していないことになっている上、社員番号と氏名を比較しているような状態に見えます。 正しくは For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row For cnt = 3 To wS.Cells(Rows.Count, "A").End(xlUp).Row If .Cells(i, "A").value = wS.cells(cnt,1).value Then wS.Cells(cnt,2).Resize(, 4).Value = .Cells(i, 2).Resize(, 4).Value End If next cnt Next i だったりしませんか?
pig_vba

2023/01/13 01:05 編集

また、EN列はcolumns(144)なのでB列.resize(,143)ですが、コード上resize(,4)なのでA-E列までしか情報はいりませんが仕様通りでしょうか?
koburon

2023/01/13 02:59 編集

コメントありがとうございます。 resize(,4)としましたが、最終行のEN列までコピーしたいので誤りです。申し訳ありません。 いただいたコメントを踏まえてシート名や最終行の変数等を追記して、コードを編集しました。 質問の「追記」の見出しに記載しております。 試しに実行したところ、80行目の「社員番号が一致するか」の条件分岐で、エラーが発生してしまいました。 If wS3.Cells(i, "A").Value = wS2.Range(cnt, 1).Value Then 「実行時エラー'1004'; 'Range'メソッドは失敗しました:_'Worksheet’オブジェクト」 というエラーメッセージでした。 セル値の取得がうまくできていないという意味だとは思いますが、原因はよく分からないですが、解決方法はありますでしょうか。
pig_vba

2023/01/13 02:34 編集

Range型は(row,colmn)指定ができません。 cells(cnt,1)にしてください。 ついでですが.resizeプロパティは「そのセルを基準に拡張する」なのでb列からリサイズした場合は1列余分になることに気を付けてください。
koburon

2023/01/13 02:59 編集

コメントありがとうございます。 Range型にしていたのがエラーの原因なのですね。 cellsに変更したところ、エラー表示はなくなりました。 また、resize部分も最終行および最終列に-1を追記しましたが、これで144列まで拡張された、という解釈でよろしいでしょうか。 コード実行後に「異動者リスト」を確認したのですが、B列から右のセル値がコピーできておらず空欄のままでした。コピーはできても貼り付けが実行されないのか、クリアしてしまったのか何が原因なのか分からない状況です。
pig_vba

2023/01/13 03:07

>また、resize部分も最終行および最終列に-1を追記しましたが、これで144列まで拡張された、という解釈でよろしいでしょうか。 はい。あってます。 >列から右のセル値がコピーできておらず空欄のままでした。 そもそもIF文を通っていない可能性がありますね…一旦2,3人分くらいにしてデバッグ実行してみてもらえますか。 マクロ画面でF8押せば1行ずつ実行することができます。 該当部分がちゃんと通過できているか確認してください。
koburon

2023/01/13 04:24

コメントありがとうございます。 >そもそもIF文を通っていない可能性がありますね…一旦2,3人分くらいにしてデバッグ実行してみてもらえますか。 >マクロ画面でF8押せば1行ずつ実行することができます。 80行目にブレークポイントを設定しF8を何度も押して1行ずつ実行してみましたが、エラーは表示されず1行目にセル値は貼りつきませんでした。 それ以降押し続けても2行目以降も同様の動きでしたが、これがIF文が通っていない、という意味でしょうか。 IF文である以上Elseが必要なのかな、とも考えたのですが、やはりコードが不足しているのでしょうか。
pig_vba

2023/01/13 04:34

82行目に到達していない、という意味でしたらそもそもIF文が間違っているということになりますね。 ただ、コード自体に不備があるようには見えないので80行目到達時点で各セルのvalue値を確認すべきかもしれません。
koburon

2023/01/13 05:19

試しに、IF文にElseを追記してどのように動作するか確認してみました。 If wS3.Cells(i, "A").Value = wS2.Range(cnt, 1).Value Then wS2.Cells(cnt, 2).Resize(, LastClm -1 ).Value = wS3.Cells(i, 2).Resize(, LastClm -1 ).Value Else Msgbox "該当する社員番号がありません" End If F8で1行ずつ実行した際、該当する社員の人数分だけこの動作を繰り返し、それが無くなると次のコードに進むという感じでした。 社員番号のセル値が同じように見えているが、実際は一致していないと判断されてしまっている可能性があります。書式が違うだけで一致しないものなのでしょうか。
pig_vba

2023/01/13 05:40

valueは書式設定を無視するはずなのでそれが原因ではないと思います。(書式設定込は.textプロパティが該当します。) ただ、コピーした結果が数値ではなく文字列やシリアル値と認識されている可能性は捨てきれません。 一度IF文前で rng1=ws2.cells... rng2=ws3.cells... と変数に格納してみてvalue値が何型になっているか確認してください。原因がこれであればCopy destinationよりCopy pasteSpecialを使うべきという結論になりそうです
koburon

2023/01/13 06:23

IF文前で、以下のコードのようにTypeName関数で、セルの値(Valueプロパティ)を調べてみました。 Dim rng As String rng = rng & TypeName(wS2.Cells(3, 1).Value) & vbCrLf rng = rng & TypeName(wS3.Cells(3, 1).Value) & vbCrLf MsgBox rng 結論から言うと、どちらもDouble型になっていました。型が異なるという理由ではないことはこれでハッキリしましたが、別の原因が分からないです。日付の場合はDouble型ではダメで例えばDate型にしないといけないということでしょうか。
pig_vba

2023/01/13 06:38

あ、それだ。 If CLng(wS3.Cells(i, "A").Value) = CLng(wS2.Cells(cnt, 1).Value) then これ試してください。予想が合ってればこれで行けるはず
koburon

2023/01/13 07:25

いただいたコードに直して実行してみましたが、B列より右に情報が貼りつけられませんでした。 いただいたコードはLong型に変換するものだと思いますが、 念のためTypeName関数(上のコード)で確認したところ、やはりどちらもDouble型のままでした。 原因は別のところにあるのかもしれません。
pig_vba

2023/01/13 08:01

おや?そうでしたか。。。Double型になってるということは浮動小数点誤差が原因だと思ったのですがこの方法だとキャストできませんでしたか…
koburon

2023/01/13 08:58

いろいろと試してみましたが、IF文だけがどうしてもうまくいかない状態ですね。 wS2とwS3が全く同じ構成のシートで値を貼りつけるだけなので、 少し強引かもしれませんが、74行目までの部分で一旦End Subにして、それ以降の処理はvlookup関数などを使ったコードで繰り返し処理して複数列コピペするようにした方が無難かなと思います。
guest

回答1

0

自己解決

いろいろと試してみましたが、IF文だけがどうしてもうまくいかない状態で、
社員名簿と全く同じ構成の異動者リストに値を貼りつけるだけなので、
74行目までの部分で一旦End Subにして、社員番号のみ貼りついた状態で終了としました。
それ以降の処理は、異動者リストのB列より右のセルにvlookup関数の数式を入れて、
行数に応じてドラッグして作成するようにします。

=VLOOKUP($A3,現在の社員名簿!$A$3:$EN$2191,B$1,FALSE)

時間がある時にvlookup関数を自動入力するVBAも開発したいと思います。
コメントいただきありがとうございました。

投稿2023/01/16 00:50

koburon

総合スコア30

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

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

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

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

ただいまの回答率
85.44%

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

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

質問する

関連した質問