データ転記の際重複する場合適切なデータを選ぶ

投稿者 : ぽこぽこ     投稿日時 : 2025/03/24(Mon) 18:17:44     OS : Windows 10     EXCEL : Office 365

---

下記のようなExcel表の転記作業において、重複する際適切なものをとってきて転記するvbを考えています。数式のようにCountIfやXlookUpを用いた方法をどのように記述すればよいかご教授いただければ幸いです。

X表
A列　B列
あつ　ダレスリ
あつ　アガツ
あつ　サエレレ
びり　カカココ
びり　フレンツ
びり　スラドレ

Y表
A列　B列
あつ　
あつ　
あつ　
びり　
びり
びり　

X表のB列をY表のB列に転記したい場合、XlookUpのみを用いた場合「あつ」「びり」がそれぞれ重複しているため、Y表のB列には一行目でヒットした「ダレスリ」しか転記されず、それ以下のものが転記されません。CountIf等でユニークなIDを作ればよいのかと思うのですが、コードの書き方がわかりません。
ご教授いただければ幸いです。よろしくお願いいたします。

投稿者 : さんこう     投稿日時 : 2025/03/25(Tue) 07:56:07

---

参考になれば。


＜vba vlookup 重複＞

https://www.google.com/search?q=vba+vlookup+%E9%87%8D%E8%A4%87

投稿者 : 名無し     投稿日時 : 2025/03/25(Tue) 09:55:19

---

＞重複する際適切なものをとってきて
何をもって適切とするかが不明。

また、「あつ」と言われてもどの「あつ」か、Excelに分かるはずもないので、ユニークなIDを作るしかないのでは。

ユニークなIDを作るには、例えば X表の
C1 =A1&COUNTIF(A$1:A1,A1)　下にコピー
とかすると、
あつ1
あつ2
あつ3
びり1
びり2
びり3
のように、一応ユニークなIDにはなるけど。

投稿者 : tek     投稿日時 : 2025/03/26(Wed) 10:12:05

---

>数式のようにCountIfやXlookUpを用いた方法
Y表のA列の値分X表の上から順に引っぱてくるということなら（私にはその数式は思いつきませんが）、
Match関数を使った一例です。

Public Const X表 = "X表"
Public Const Y表 = "Y表"

Sub testMatch関数()
    Dim x As Worksheet
    Dim dd, cd
    Dim i As Long, m
    
    make_X表
    make_Y表 20, 7, 10
    Stop
    
    Set x = Worksheets(X表)
    dd = x.Range("a1").CurrentRegion.Resize(, 1).Value
    
    With Worksheets(Y表)
        cd = .Range("A1").CurrentRegion.Resize(, 1).Value
        For i = 2 To UBound(cd)
            m = Application.Match(cd(i, 1), dd, 0)
            If IsNumeric(m) Then
                dd(m, 1) = Empty
                cd(i, 1) = x.Cells(m, 2).Value
            Else
                cd(i, 1) = Empty
            End If
        Next
        cd(1, 1) = x.Cells(1, 2).Value
        .Range("B1").Resize(UBound(cd)).Value = cd
        .Activate
    End With
End Sub

Sub make_X表(Optional n As Long)
    Dim xx(1 To 100, 1 To 2)
    Dim i As Long
    
    If Evaluate("isref(" & X表 & "!a1)") Then Exit Sub
    
    For i = LBound(xx) To UBound(xx)
        xx(i, 1) = "A" & Format(WorksheetFunction.RandBetween(1, 20), "00")
        xx(i, 2) = "B" & Format(i, "000")
    Next
    
    With Worksheets.Add
        .Name = X表
        .Range("a1:b1").Value = Array("A列", "B列")
        .Range("a2").Resize(UBound(xx), UBound(xx, 2)) = xx
    End With
End Sub

Sub make_Y表(n As Long, min As Long, max As Long)
    Dim Ysh As Worksheet
    Dim xx
    Dim i As Long
    
    ReDim xx(1 To n, 1 To 1)
    For i = LBound(xx) To UBound(xx)
        xx(i, 1) = "A" & Format(WorksheetFunction.RandBetween(min, max), "00")
    Next
    
    On Error Resume Next
    Set Ysh = Worksheets(Y表)
    On Error GoTo 0
    If Ysh Is Nothing Then Set Ysh = Worksheets.Add
    With Ysh
        .Name = Y表
        .UsedRange.ClearContents
        .Range("a1").Value = "A列"
        .Range("a2").Resize(UBound(xx)) = xx
    End With
End Sub

投稿者 : jindon     投稿日時 : 2025/04/28(Mon) 14:20:00

---

こういうことですか？

Sub test()
    Dim s$(1)
    With Sheets("X表").[a1].CurrentRegion
        s(0) = .Columns(1).Address(, , , 1)
        s(1) = .Columns(2).Address(, , , 1)
    End With
    With Sheets("Y表")
        With .Range("b1", .Range("a" & Rows.Count).End(xlUp)(1, 2))
            .Formula2 = "=index(" & s(1) & ",small(if(" & s(0) & "=a1,row(" & s(0) & ")),countif(a$1:a1,a1)))"
        End With
    End With
End Sub