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

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

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

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

Q&A

解決済

3回答

889閲覧

B列とC列でどちらもデータが重複した場合のみ、Sheet1から二つの行データをSheet2に転記するVBA

hoka

総合スコア9

VBA

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

0グッド

1クリップ

投稿2019/08/02 07:22

前提・実現したいこと

<シート1>
イメージ説明
<シート2>
イメージ説明
図のようにB列とC列でどちらもデータが重複した場合のみ、Sheet1から二つの行データをSheet2に転記するVBAが作りたいです。

B列のみ重複チェックをしてSheet2に転記するマクロを試してみたのですが、同姓同名の方のデータも抽出されてしまったので、方法があれば教えて頂きたいです。

よろしくお願い致します。

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

エラーメッセージ

該当のソースコード

ソースコード

試したこと

VBA初心者でどうすればよいのか分かりません。

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

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

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

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

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

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

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

torisan

2019/08/02 07:54

『B列のみ重複チェックをしてSheet2に転記するマクロ』の記載をお願いします。
hoka

2019/08/02 08:01

Public Sub b() Dim r1 As Double Dim r2 As Double Dim rLST As Double Dim cntR As Double Dim cntA As Double Dim cnt As Double Dim i As Integer Dim pick1() Dim pick2() Dim colE() '//-----シート名の指定---- Const SNM1 = "Sheet1" Const SNM2 = "Sheet2" '------------------------// '//-----シート1データ開始行指定---- Const srt1 = 2 '--------------------------------// '//-----シート2データ貼付行指定---- Const srt2 = 2 '--------------------------------// 'シート1のデータ最終行を取得 Worksheets(SNM1).Select Worksheets(SNM1).Range("A" & srt1).Select Selection.End(xlDown).Select rLST = ActiveCell.Row r1 = srt1 cntR = 1 Do Until r1 > rLST '選択行が可視の時 If Sheets(SNM1).Rows(r1).Hidden = False Then 'B列の値が「-」かつ「---」でない時 If Worksheets(SNM1).Range("B" & r1) <> "-" And Worksheets(SNM1).Range("B" & r1) <> "---" Then '行番号を取得 ReDim Preserve pick1(cntR) pick1(cntR) = r1 'B列の値を取得 ReDim Preserve colE(cntR) colE(cntR) = Range("B" & r1) cntR = cntR + 1 End If End If r1 = r1 + 1 Loop '対象行(可視&B列がハイフンでない)内でのB列重複確認 cntR = 1 For cntA = 1 To UBound(pick1) i = 0 For cnt = 1 To UBound(colE) If Worksheets(SNM1).Range("B" & pick1(cntA)) = colE(cnt) Then i = i + 1 '重複が1つでもあったら比較処理を終了(時短対策) If i > 1 Then Exit For End If End If Next '重複の行番号を取得 If i > 1 Then ReDim Preserve pick2(cntR) pick2(cntR) = pick1(cntA) cntR = cntR + 1 End If Next 'シート2へコピペ r2 = srt2 For cnt = 1 To UBound(pick2) Worksheets(SNM1).Rows(pick2(cnt) & ":" & pick2(cnt)).Copy Worksheets(SNM2).Select Worksheets(SNM2).Rows(r2 & ":" & r2).Select ActiveSheet.Paste r2 = r2 + 1 Next 'アクティブセルをA1にしておく Worksheets(SNM1).Select Application.CutCopyMode = False Worksheets(SNM1).Range("A1").Select Worksheets(SNM2).Select Worksheets(SNM2).Range("A1").Select End Sub こちらになります。 よろしくお願い致します。
sazi

2019/08/02 08:15

社員IDの重複の検出では駄目な理由がありますか?
hoka

2019/08/02 09:46

社員IDを複数持っている社員がいるので、社員IDでの重複の検出が難ししいので、氏名と生年月日で検出したいと思っております。
Secret

2019/08/02 13:30

ソースはコメントではなく質問の編集で追加してください
guest

回答3

0

colE(cntR)に値を設定する際、Bカラムの値とCカラムの値を結合して設定しておき、比較する際の左辺もRange("B"&pick1(cntA))とRange("C"&pick1(cntA))を結合しておけばいいのでは?

投稿2019/08/02 10:51

sage

総合スコア1216

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

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

0

ベストアンサー

B列のみ重複チェックをしてSheet2に転記するマクロを試してみた

当然、C列の判定をしていないため、意図した結果になりません。
B列とC列を同時にチェックする必要がありますので、sageさんがおっしゃる通り、連結すれば解決すると思います。

配列を使うことで、何か混乱が起きているのでしょうか?
念のため、配列を使わない解法を記載しておきます。
A列に1列挿入し、最終行まで連番をつけておき、氏名・生年月日で並び替える。
連続して同じ氏名・生年月日だった場合に、Sheet2にコピーする。
すべての処理が終わったら連番で並び替えて、A列を削除する。(並び替え前の状態に戻す)

あと、プロシージャを機能ごとに分割された方が、可読性と視認性、再利用性が良くなるかと思います。

VBA

1Option Explicit 2 3Sub ListingDuplicate() 4 5 Application.ScreenUpdating = False 6 7 Dim lastRow As Long: lastRow = Cells(Rows.Count, 1).End(xlUp).Row 8 9 Call SetSerialNumber(lastRow) 10 Call SortNameAndBirthday(lastRow) 11 Call CheckDuplicateAndListing(lastRow) 12 Call SortSerialNumber(lastRow) 13 Columns(1).Delete 14 15 Application.ScreenUpdating = True 16 17End Sub 18 19'A列に1列挿入し、最終行まで連番入力 20Sub SetSerialNumber(lastRow As Long) 21 22 Columns(1).Insert 23 24 Dim i As Long 25 26 For i = 1 To lastRow 27 Cells(i, 1) = i 28 Next 29 30End Sub 31 32'氏名と生年月日で並べ替える 33Sub SortNameAndBirthday(lastRow As Long) 34 35 With ActiveSheet.Sort 36 .SortFields.Clear 37 .SortFields.Add2 Key:=Range("C1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 38 .SortFields.Add2 Key:=Range("D1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 39 .SetRange Range("A1:E" & lastRow).CurrentRegion 40 .Header = xlYes 41 .Apply 42 End With 43 44End Sub 45 46'氏名と生年月日が連続して一致していたらSheet2にリストアップする 47Sub CheckDuplicateAndListing(lastRow As Long) 48 49 Dim SNM2 As Worksheet 50 Set SNM2 = Sheets("Sheet2") 51 52 Dim pasteRow As Long: pasteRow = 2 53 Dim i As Long: i = 3 54 Dim streak As Boolean: streak = False 55 56 Do While Cells(i, 1) <> "" 57 If Cells(i, 3) = Cells(i - 1, 3) And Cells(i, 4) = Cells(i - 1, 4) Then 58 Select Case streak 59 Case True 60 SNM2.Cells(pasteRow, 1) = Cells(i, 2) 61 SNM2.Cells(pasteRow, 2) = Cells(i, 3) 62 SNM2.Cells(pasteRow, 3) = Cells(i, 4) 63 SNM2.Cells(pasteRow, 4) = Cells(i, 5) 64 Case False 65 SNM2.Cells(pasteRow, 1) = Cells(i - 1, 2) 66 SNM2.Cells(pasteRow, 2) = Cells(i - 1, 3) 67 SNM2.Cells(pasteRow, 3) = Cells(i - 1, 4) 68 SNM2.Cells(pasteRow, 4) = Cells(i - 1, 5) 69 pasteRow = pasteRow + 1 70 SNM2.Cells(pasteRow, 1) = Cells(i, 2) 71 SNM2.Cells(pasteRow, 2) = Cells(i, 3) 72 SNM2.Cells(pasteRow, 3) = Cells(i, 4) 73 SNM2.Cells(pasteRow, 4) = Cells(i, 5) 74 streak = True 75 End Select 76 pasteRow = pasteRow + 1 77 Else 78 streak = False 79 End If 80 i = i + 1 81 Loop 82 83End Sub 84 85'A列の連番順に並び替えて、最初の順番に戻す 86Sub SortSerialNumber(lastRow As Long) 87 88 With ActiveSheet.Sort 89 .SortFields.Clear 90 .SortFields.Add2 Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 91 .SetRange Range("A1:E" & lastRow).CurrentRegion 92 .Header = xlYes 93 .Apply 94 End With 95 96End Sub 97

投稿2019/08/02 16:22

Secret

総合スコア220

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

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

hoka

2019/08/03 00:21

解決いたしました。 ありがとうございました!!
guest

0

辞書を使った方法です。

vba

1Dim dict As Object 2 3 Set dict = CreateObject("Scripting.Dictionary") 4 5 With ActiveWorkbook 6 For i = 1 To .Sheets(1).UsedRange.Rows.Count 7 '重複していない場合 8 If Not dict.Exists(.Sheets(1).Cells(i, 1).Value & .Sheets(1).Cells(i, 2).Value) Then 9 dict.Add .Sheets(1).Cells(i, 1).Value & .Sheets(1).Cells(i, 2).Value, i 10 '重複した場合 11       Else 12 'シート2へコピーする 13 End If 14 Next i 15 End With

投稿2019/08/02 11:26

meg_

総合スコア10577

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

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

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

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

ただいまの回答率
85.50%

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

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

質問する

関連した質問