Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

8718 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

▼

【31567】データマッチングについて マッチ 05/11/25(金) 17:00

【31571】Re:データマッチングについて ichinose 05/11/25(金) 18:08

【31575】Re:データマッチングについて だるま 05/11/25(金) 18:58

【31586】Re:データマッチングについて Kein 05/11/25(金) 21:07

【31590】Re:データマッチングについて Hirofumi 05/11/25(金) 22:55


	【31567】データマッチングについて

マッチ - 05/11/25(金) 17:00 -


	引用なし

	パスワード

はじめまして。どうにも出来ずに悩んでいます。
お願いします。下記、Aセルに社員番号、Bセルに
シーケンス番号があります。AセルとＢセルを
マッチさせ、Ａセルのみの社員番号※１とＢセルのみ
シーケンス番号のみ※２出したいのですが。

　　A　　 B
1　1001　1002
2　1002　1003
3　1003　1004
4　1004　1005
5　1006　1006
6　1007　1008

--------------------

　 ※1　　※2
　 1001　1008
　 1007


	【31571】Re:データマッチングについて

ichinose - 05/11/25(金) 18:08 -


	引用なし

	パスワード

▼マッチさん：
こんばんは。

>はじめまして。どうにも出来ずに悩んでいます。
マッチングというのは、色々な方法が考えられますから、
楽しみながらやりましょう！！

>お願いします。下記、Aセルに社員番号、Bセルに
>シーケンス番号があります。AセルとＢセルを
>マッチさせ、Ａセルのみの社員番号※１とＢセルのみ
>シーケンス番号のみ※２出したいのですが。
>
>　　A　　 B
>1　1001　1002
>2　1002　1003
>3　1003　1004
>4　1004　1005
>5　1006　1006
>6　1007　1008
>
>--------------------
>
>　 ※1　　※2
>　 1001　1008
　 1007　1005 ←これもそうですよね？

アクティブシートのＡ列、Ｂ列の一行目からデータがあるとします。

結果はＤ列、Ｅ列に表示します。
'==========================================================
Sub main()
　　Dim idx as long
　　Dim 列(1 To 2) As Range
　　Dim crng As Range
　　Dim unmatch As Range
　　Set 列(1) = Range("a1", Cells(Rows.Count, 1).End(xlUp))
　　Set 列(2) = Range("b1", Cells(Rows.Count, 2).End(xlUp))
　　For idx = 1 To 2
　　　 Set unmatch = Nothing
　　　 For Each crng In 列(idx)
　　　　　If IsError(Application.Match(crng, 列(IIf(idx = 1, 2, 1)), 0)) Then
　　　　　　 If unmatch Is Nothing Then
　　　　　　　　Set unmatch = crng
　　　　　　 Else
　　　　　　　　Set unmatch = Union(unmatch, crng)
　　　　　　　　End If
　　　　　　 End If
　　　　　Next
　　　 If Not unmatch Is Nothing Then
　　　　　unmatch.Copy Cells(1, idx + 3)
　　　　　End If
　　　 Next
End Sub

試してみてください。


	【31575】Re:データマッチングについて

だるま

- 05/11/25(金) 18:58 -


	引用なし

	パスワード

こんにちは

こんなソフトもあります。
よろしければご検討ください。^d^

秒速！ダブリ出しII
http://www.vector.co.jp/soft/winnt/business/se381365.html


	【31586】Re:データマッチングについて

Kein - 05/11/25(金) 21:07 -


	引用なし

	パスワード

こんな感じでどうかな ?
データのあるシートを開いて実行します。アクティブシートの次のシートのA,B列に
抽出した重複値を表示します。

Sub MyMatch()
　 Dim LR1 As Long, LR2 As Long
　 Dim Nm As String
　 Dim x As Variant, y As Variant
　
　 Application.ScreenUpdating = False
　 With ActiveSheet
　　　If .Index = Worksheets.Count Then Exit Sub
　　　Nm = .Name & "!"
　　　LR1 = .Range("A65536").End(xlUp).Row
　　　LR2 = .Range("B65536").End(xlUp).Row
　　　With .Next
　　　　 .Cells.ClearContents
　　　　 .Range("A1:A" & LR1).Formula = _
　　　　 "=IF(ISERR(MATCH(" & Nm & "$A1," & Nm & "$B:$B,0)),""Z"",ROW()&"".""&$A1)"
　　　　 .Range("C1:C" & LR2).Formula = _
　　　　 "=IF(ISERR(MATCH(" & Nm & "$B1," & Nm & "$A:$A,0)),""Z"",ROW()&"",""&$B1)"
　　　　 .Range("A:C").Copy
　　　　 .Range("A1").PasteSpecial xlPasteValues
　　　　 .Range("A1:A" & LR1).Sort Key1:=.Columns(1), _
　　　　 Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortColumns
　　　　 .Range("C1:C" & LR2).Sort Key1:=.Columns(3), _
　　　　 Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortColumns
　　　　 x = Application.Match("Z", .Range("A:A"), 0)
　　　　 If Not IsError(x) Then
　　　　　　.Range("A" & x & ":A65536").ClearContents
　　　　 End If
　　　　 y = Application.Match("Z", .Range("C:C"), 0)
　　　　 If Not IsError(y) Then
　　　　　　.Range("C" & y & ":C65536").ClearContents
　　　　 End If
　　　　 .Range("A1:A" & LR1).TextToColumns DataType:=xlDelimited, _
　　　　 Comma:=True
　　　　 .Range("C1:C" & LR2).TextToColumns DataType:=xlDelimited, _
　　　　 Comma:=True
　　　　 .Columns(3).Delete xlShiftToLeft
　　　　 .Columns(1).Delete xlShiftToLeft
　　　　 .Activate
　　　End With
　 End With
　 With Application
　　　.CutCopyMode = False
　　　.ScreenUpdating = True
　 End With
End Sub


	【31590】Re:データマッチングについて

Hirofumi - 05/11/25(金) 22:55 -


	引用なし

	パスワード

Sheet1のA、Bに比較するデータが有り、結果をSheet2のA,Bに出します
尚、Sheet1には、列見出しが有る物とします

Option Explicit
Option Compare Text

Public Sub Extraction()

　　Dim i As Long
　　Dim rngList1 As Range
　　Dim lngEnd1 As Long
　　Dim vntList1 As Variant
　　Dim lngRow1 As Long
　　Dim rngList2 As Range
　　Dim lngEnd2 As Long
　　Dim vntList2 As Variant
　　Dim lngRow2 As Long
　　Dim rngExtract1 As Range
　　Dim lngExtract1 As Long
　　Dim rngExtract2 As Range
　　Dim lngExtract2 As Long
　　Dim strProm As String
　　
　　'抽出データを書きこむ位置を指定
　　With Worksheets("Sheet2")
　　　　Set rngExtract1 = .Cells(1, "A")
　　　　Set rngExtract2 = .Cells(1, "B")
　　End With
　　
　　'Sheet1のA1を基準とします（Listの左上隅）
　　Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
　　'基準に就いて
　　With rngList1
　　　　'行数を取得
　　　　lngEnd1 = .Offset(65536 - .Row).End(xlUp).Row - .Row
　　　　If lngEnd1 <= 0 Then
　　　　　　strProm = .Address(False, False) & "以下にデータが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'品番列を配列に取得
　　　　vntList1 = .Offset(1).Resize(lngEnd1).Value
　　End With
　　
　　'"Sheet1"のB1を基準とする
　　Set rngList2 = Worksheets("Sheet1").Cells(1, "B")
　　'基準に就いて
　　With rngList2
　　　　'行数を取得
　　　　lngEnd2 = .Offset(65536 - .Row).End(xlUp).Row - .Row
　　　　If lngEnd2 <= 0 Then
　　　　　　strProm = .Address(False, False) & "以下にデータが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'品目番号列を配列に取得
　　　　vntList2 = .Offset(1).Resize(lngEnd2).Value
　　End With
　　
　　'A列の書き込み行を初期値に（Offse値）
　　lngExtract1 = 0
　　'A列の比較位置
　　lngRow1 = 1
　　'B列の書き込み行を初期値に（Offse値）
　　lngExtract2 = 0
　　'B列の比較位置
　　lngRow2 = 1
　　'A列若しくは,B列が最終行に達するまで繰り返し
　　Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
　　　　'比較結果に就いて
　　　　Select Case vntList1(lngRow1, 1)
　　　　　　Case Is = vntList2(lngRow2, 1) 'Matchiした場合
　　　　　　　　'両データの比較位置の更新
　　　　　　　　lngRow1 = lngRow1 + 1
　　　　　　　　lngRow2 = lngRow2 + 1
　　　　　　Case Is > vntList2(lngRow2, 1) 'B列固有行の場合
　　　　　　　　'出力位置を更新
　　　　　　　　lngExtract2 = lngExtract2 + 1
　　　　　　　　'B列の値を配列に出力
　　　　　　　　vntList2(lngExtract2, 1) = vntList2(lngRow2, 1)
　　　　　　　　'B列の比較位置を更新
　　　　　　　　lngRow2 = lngRow2 + 1
　　　　　　Case Is < vntList2(lngRow2, 1) 'A列固有行の場合
　　　　　　　　'出力位置を更新
　　　　　　　　lngExtract1 = lngExtract1 + 1
　　　　　　　　'A列のの値を配列に出力
　　　　　　　　vntList1(lngExtract1, 1) = vntList1(lngRow1, 1)
　　　　　　　　'A列の比較位置を更新
　　　　　　　　lngRow1 = lngRow1 + 1
　　　　End Select
　　Loop
　　
　　Application.ScreenUpdating = False
　　
　　'残ったA列の固有値を配列に出力
　　For i = lngRow1 To lngEnd1
　　　　'出力位置を更新
　　　　lngExtract1 = lngExtract1 + 1
　　　　'A列のの値を配列に出力
　　　　vntList1(lngExtract1, 1) = vntList1(i, 1)
　　Next i
　　'シートに配列を出力
　　rngExtract1.Offset(1).Resize(lngExtract1).Value = vntList1
　　
　　'残ったB列の固有値を配列に出力
　　For i = lngRow2 To lngEnd2
　　　　'出力位置を更新
　　　　lngExtract2 = lngExtract2 + 1
　　　　'B列の値を配列に出力
　　　　vntList2(lngExtract2, 1) = vntList2(i, 1)
　　Next i
　　'シートに配列を出力
　　rngExtract2.Offset(1).Resize(lngExtract2).Value = vntList2
　　
　　Application.ScreenUpdating = True
　　
　　strProm = "処理が完了しました"
　　
Wayout:

　　Set rngList1 = Nothing
　　Set rngList2 = Nothing
　　Set rngExtract1 = Nothing
　　Set rngExtract2 = Nothing
　　　　
　　MsgBox strProm, vbInformation
　　
End Sub


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

8718 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free