[[20190103180426]] 『VBA 2つのセルから共通要素を抽出する方法』(VBA初心者です) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『VBA 2つのセルから共通要素を抽出する方法』(VBA初心者です)

 今回、段階的に3つの質問をさせていただきたく投稿させていただきます。

 【1】 共通する要素の抽出

 要素Si	矢印の先Pi	矢印の元Qi	Pi AND Qi   Pi AND Qi = Pi
 1	1,5	    1,2,6	
 2	1,2,3,4,5	2,6	
 3	3,4,5	    2,3,4,6	
 4	3,4,5	    2,3,4,6	
 5	5	    1,2,3,4,5,6	
 6	1,2,3,4,5,6	6	

 この状態の表で、PiとQiの列のセルに共通する要素を、
対応するPi AND Qiの列に抽出する方法を知りたいです。
具体的には下記のような結果が得られればと思います。

 要素Si	矢印の先Pi	矢印の元Qi	Pi AND Qi	Pi AND Qi = Pi
 1	1,5	    1,2,6     	1	
 2	1,2,3,4,5	2,6	    2	
 3	3,4,5	    2,3,4,6  	3,4	
 4	3,4,5	    2,3,4,6  	3,4	
 5	5	    1,2,3,4,5,6	5     	
 6	1,2,3,4,5,6	6	    6	 

 【2】要素を除外し、表を再構成
    【1】で作成した表で、PiとPi AND Qiの値が全く同じならば、
    対応するPi AND Qi = Piの列に*をつけました。
    Pi AND Qi = Piの列に*がついている要素を表からすべて除外し、
  新しく表を作成する方法が知りたいです。
  具体的には下記のような表が作成されることを求めています。

 要素Si	矢印の先Pi	矢印の元Qi	Pi AND Qi	Pi AND Qi = Pi
 1	1,5	    1,2,6	    1	
 2	1,2,3,4,5	2,6	    2	
 3	3,4,5	    2,3,4,6 	3,4	
 4	3,4,5	    2,3,4,6 	3,4	
 5	5	    1,2,3,4,5,6	5     	*
 6	1,2,3,4,5,6	6	    6	
     5を除外して表を下に再構成		

 要素Si	矢印の先Pi	矢印の元Qi	Pi AND Qi	Pi AND Qi = Pi
 1	1	    1,2,6	    1	    *
 2	1,2,3,4	2,6	2	
 3	3,4	    2,3,4,6	    3,4	    *
 4	3,4	    2,3,4,6	    3,4    	*
 6	1,2,3,4,6	6	    6	
     1,3,4を除外して表を下に再構成		

 ※これを繰り返しやることで、

 要素Si	矢印の先Pi	矢印の元Qi	Pi AND Qi	Pi AND Qi = Pi
 2	2	    2,6	    2    	*
 6	2,6	    6	    6	
     2を除外して表を下に再構成		

 要素Si	矢印の先Pi	矢印の元Qi	Pi AND Qi	Pi AND Qi = Pi
 6	6	    6	    6	    *
     6が最下位の要素

 という結果を最終的に得たいと考えています。

 どうかよろしくお願いいたします。

< 使用 Excel:Excel2016、使用 OS:Windows10 >


【訂正】
今回、段階的に3つの質問をさせていただきたく投稿させていただきます。

今回、段階的に2つの質問をさせていただきたく投稿させていただきます。
(VBA初心者です) 2019/01/03(木) 21:30

 >VBA初心者です

 ってことなんで、ご自分でどれくらいできたのでしょうか?
 そのコードも提示しておいた方がいいと思いますよ。
(BJ) 2019/01/03(木) 22:43

BJさん

ご指摘ありがとうございます。
現在自分で書けているのは以下の通りです。

Sub test()

    Dim arr1() As String, arr2() As String, i As Integer, j As Integer, msg As String

    arr1 = Split(Range("I23"), ",")
    arr2 = Split(Range("J23"), ",")

    For i = LBound(arr1) To UBound(arr1)
        For j = LBound(arr2) To UBound(arr2)
            If arr1(i) = arr2(j) Then
            Str = Str & arr1(i) & ","
        Next j
    Next i

    Range("K23") = Str

End Sub
(VBA初心者です) 2019/01/03(木) 23:03


すいません、現在できているのはこちらです。
Sub test()
    Dim arr1() As String, arr2() As String, i As Integer, j As Integer, Str As String

    arr1 = Split(Range("I23"), ",")
    arr2 = Split(Range("J23"), ",")

    For i = LBound(arr1) To UBound(arr1)
        For j = LBound(arr2) To UBound(arr2)
            If arr1(i) = arr2(j) Then
            Str = Str & arr1(i) & ","
            End If
        Next j
    Next i

    Range("K23") = Str

End Sub

(VBA初心者です) 2019/01/03(木) 23:09


Sub main()
'A列:要素Si B列:矢印の先Pi C列:矢印の元Qi D列:Pi AND Qi E列:Pi AND Qi = Pi
'一行目は見出し
    Dim dt(), dn, c As Range, x, i As Long, j As Long, k As Long
    For Each c In Range("B2:B" & Rows.Count).SpecialCells(2)
        Erase dt
        k = 0
            For i = 0 To UBound(Split(c.Value, ","))
                For j = 0 To UBound(Split(c.Offset(, 1).Value, ","))
                    If Split(c.Value, ",")(i) = Split(c.Offset(, 1).Value, ",")(j) Then
                    ReDim Preserve dt(k)
                    dt(k) = Split(c.Value, ",")(i)
                    k = k + 1
                    End If
                Next j
            Next i
        c.Offset(, 2).Value = Join(dt, ",")
        If c.Offset(, 2).Value = c.Value Then c.Offset(, 3).Value = "*"
    Next c
    For i = Range("E" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("E" & i).Value = "*" Then
        dn = CStr(Range("D" & i).Value)
        For Each c In Range("B2:C" & Rows.Count).SpecialCells(2)
            For Each x In Split(dn, ",")
            Erase dt()
            k = 0
            For j = 0 To UBound(Split(c.Value, ","))
                If Split(c.Value, ",")(j) <> x Then
                    ReDim Preserve dt(k)
                    dt(k) = Split(c.Value, ",")(j)
                    k = k + 1
                End If
            Next j
            c.Value = Join(dt, ",")
            Next x
        Next c
        Rows(i).Delete
        End If
    Next i
    MsgBox "繰り返して実行してください"
End Sub

(mm) 2019/01/04(金) 11:59


mm 様

投稿者です。

ありがとうございます。
完璧すぎてぐうの音も出ません。
大変助かりました。

もし可能ならば、F列に取り除いた要素を入力表示させることは可能ですか?
カンマ区切りでF1に表示できればなお、ありがたいです。
(VBA初心者です) 2019/01/04(金) 18:22


連投失礼いたします。

先ほどの補足です。
入力表示させるのは、
今までの操作で取り除いたすべての要素ではなく、
1回の操作で取り除いたものです。

(VBA初心者です) 2019/01/04(金) 18:36


 こんばんは!ってもう夜中だね(^^;
Meも忙しいのよねぇ、、、、でも、気にしないでください。好きでやってますから(笑)

 で、あまり検証していないのと、やたらと変数が多いのが気になります。( ̄▽ ̄;)
上手く行ったのはたまたまかもしれません。
取り敢えず、もう、寝ます。
おやすみなさいzzzzzzzzzzzzzzzzzzzzzz

 Option Explicit
Sub てすと()
Dim MyA As Variant
Dim MyB As Variant
Dim MyDic As Object
Dim MyStr() As Variant
Dim MyKeys As Variant
Dim MyMsg As Variant
Dim 仮Pi() As Variant
Dim 仮Qi() As Variant
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim xx() As Variant
Dim yy() As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim kk As Long
Dim n As Long
Dim l As Long
Dim MyFlg As Boolean
'出力先を初期化
Range("F:K").Clear
Range("F1").Value = "削除したもの"
'データをMyAに取得
MyA = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value
Set MyDic = CreateObject("Scripting.Dictionary")
Do
    ReDim 本Pi(LBound(MyA, 1) To UBound(MyA, 1))
    ReDim 本Qi(LBound(MyA, 1) To UBound(MyA, 1))
    ReDim 仮Pi(LBound(MyA, 1) To UBound(MyA, 1))
    ReDim 仮Qi(LBound(MyA, 1) To UBound(MyA, 1))
    ReDim 共通Pi(LBound(MyA, 1) To UBound(MyA, 1))
    ReDim 新Pi(LBound(MyA, 1) To UBound(MyA, 1))
    ReDim 新Qi(LBound(MyA, 1) To UBound(MyA, 1))
    ReDim w(LBound(MyA, 1) To UBound(MyA, 1))
    ReDim ww(LBound(MyA, 1) To UBound(MyA, 1))
    '出力先の初期化
    Range("G:K").Clear
    Range("G1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyA
    'MyAに一次元下限+1から上限までループ
    For i = LBound(MyA, 1) + 1 To UBound(MyA, 1)
        'Splitで分割
        x = Split(MyA(i, 2), ",")
        y = Split(MyA(i, 3), ",")
        本Pi(i) = x
        本Qi(i) = y
        k = 0
        ReDim v(1 To 1)
        '矢印の先Piを矢印の元Qiにあるか検索
        'あればvに取得してwに取得
        For j = LBound(x) To UBound(x)
            z = Application.Match(x(j), y, 0)
            If Not IsError(z) Then
                k = k + 1
                ReDim Preserve v(1 To k)
                v(k) = x(j)
                仮Pi(i) = v
            End If
        Next
    Next
    'MyAに一次元下限+1から上限までループ
    For i = LBound(MyA, 1) + 1 To UBound(MyA, 1)
        x = 本Pi(i - 1)
        z = 仮Pi(i - 1)
        If IsArray(x) * IsArray(z) Then
            '同じだったらvvに取得
            If Join(x, ",") = Join(z, ",") Then
                'バラバラにしてMyDicに取得
                For j = LBound(x) To UBound(x)
                    MyDic(x(j)) = Empty
                Next
            End If
        End If
    Next
    MyKeys = MyDic.Keys
    If MyDic.Count = 0 Then
        MsgBox "処理が完了しました。"
        Set MyDic = Nothing
        Erase MyA, MyKeys, 本Pi, 本Qi, 新Pi, 新Qi, 仮Pi, 仮Qi, 共通Pi, w, ww, v, x, y
        Exit Sub
    End If
    For i = LBound(MyKeys) To UBound(MyKeys)
        MyMsg = Join(MyKeys, vbCrLf)
    Next
    MsgBox "共通のKeyは、" & vbCrLf & vbCrLf & MyMsg & vbCrLf & vbCrLf & "です"

    Range("F" & Rows.Count).End(xlUp).Offset(1).Value = Join(MyKeys, ",")

    '共通Piを本Pi 本Qi から削除
    'MyAに一次元下限+1から上限までループ
    For i = LBound(MyA, 1) + 1 To UBound(MyA, 1)
        x = 本Pi(i)
        k = 0
        kk = 0
        For j = LBound(x) To UBound(x)
            z = Application.Match(x(j), MyKeys, 0)
            If IsError(z) Then
                k = k + 1
                ReDim Preserve xx(1 To k)
                xx(k) = x(j)
            End If
        Next
        新Pi(i) = xx
        Erase xx
        y = 本Qi(i)
        k = 0
        kk = 0
        For j = LBound(y) To UBound(y)
            z = Application.Match(y(j), MyKeys, 0)
            If IsError(z) Then
                kk = kk + 1
                ReDim Preserve yy(1 To kk)
                yy(kk) = y(j)
            End If
        Next
        新Qi(i) = yy
        Erase yy
    Next
    For i = LBound(MyA, 1) + 1 To UBound(MyA, 1)
        If IsArray(新Qi(i)) Then
            w(i) = Join(新Pi(i), ",")
        End If
        If IsArray(新Pi(i)) Then
            ww(i) = Join(新Qi(i), ",")
        End If
    Next
    本Qi = w
    本Pi = ww
    MyFlg = True
    x = Empty
    y = Empty
    MyDic.RemoveAll
    'データの更新
    For i = LBound(MyA, 1) + 1 To UBound(MyA, 1)
        MyA(i, 2) = 本Qi(i)
        MyA(i, 3) = 本Pi(i)
    Next
Loop
End Sub
v(=∩_∩=)v
(SoulMan) 2019/01/05(土) 01:55

SoulMan様  投稿主です。
 お礼が遅くなり大変申し訳ございません。
 本当に助かりました! ありがとうございます!
(VBA初心者です) 2019/01/16(水) 11:09

 ちょっと面白そうな案件だったので、記念参加です。
 正規表現苦手だったので、これが正しいか今でもわかりません。

    Option Explicit
    Sub StartchkPiQi()
        Dim cnt As Long
        Dim i As Long
        cnt = 1
        Range(Cells(Rows.Count, "G").End(xlUp), Cells(1, Columns.Count).End(xlToLeft)).ClearContents
        Call chkPiQi(Range("F2", Cells(Rows.Count, "A").End(xlUp)), cnt)
        For i = 1 To cnt
            Range("A1:F1").Offset(, i * 6).Value = Range("A1:F1").Value
        Next i
    End Sub
    Private Sub chkPiQi(ByVal r As Range, ByRef cnt As Long)
        Dim w As Variant
        Dim i As Long
        Dim v As Variant
        Dim n As Long
        Dim rp As String
        Dim k As Variant
        w = r.Value
        ReDim v(1 To UBound(w, 1), 1 To UBound(w, 2))
        n = 0
        With CreateObject("VBScript.RegEXP")
            .Global = True
            For i = 1 To UBound(w, 1)
                .Pattern = "[^" & Replace(w(i, 3), ",", "|") & "]"
                w(i, 4) = Replace(trim(.Replace(w(i, 2), " ")), " ", ",")
                If CStr(w(i, 2)) = w(i, 4) Then
                    w(i, 5) = "*"
                    w(i, 6) = w(i, 2)
                    rp = rp & Chr(2) & w(i, 2)
                Else
                    n = n + 1
                    v(n, 1) = w(i, 1)
                    v(n, 2) = w(i, 2)
                    v(n, 3) = w(i, 3)
                End If
            Next i
            For Each k In Split(rp, Chr(2))
                If k <> "" Then
                    .Pattern = "(" & Replace(k, ",", "|") & "),?|,?(" & Replace(k, ",", "|") & ")"
                    For i = 1 To n
                        v(i, 2) = .Replace(v(i, 2), "")
                    Next i
                End If
            Next k
        End With
        r.Value = w
        r.Offset(, 6).Value = v
        If n > 1 Then
            cnt = cnt + 1
            Call chkPiQi(r.Offset(, 6).Resize(n), cnt)
        End If
    End Sub

(稲葉) 2019/01/16(水) 17:40


 正規表現で

 Sub test()
     Dim a, i As Long, x, m As Object, ptn As String, temp As String, txt As String
     a = Cells(1).CurrentRegion.Resize(, 4).Value
     With CreateObject("VBScript.RegExp")
         .Global = True
         Do While UBound(a, 1) > 2
             If txt <> "" Then ptn = Join(Split(Mid$(txt, 2), ","), "|")
             If Len(x) Then
                 a = Application.Index(a, Application.Transpose( _
                    Split("1" & x, ",")), Evaluate("column(" & _
                    Range("a1").Resize(, UBound(a, 2)).Address & ")"))
             End If
             txt = "": x = ""
             For i = 2 To UBound(a, 1)
                 temp = ""
                 If Len(ptn) Then
                     .Pattern = ptn
                     a(i, 2) = .Replace(a(i, 2), "")
                     .Pattern = "^,+|,+$"
                     a(i, 2) = .Replace(a(i, 2), "")
                     .Pattern = ",{2,}"
                     a(i, 2) = .Replace(a(i, 2), ",")
                     If a(i, 2) <> "" Then x = x & "," & i
                 End If
                 If a(i, 2) <> "" Then
                     .Pattern = Replace(a(i, 2), ",", "|")
                     For Each m In .Execute(a(i, 3))
                         temp = temp & IIf(temp <> "", ",", "") & m
                     Next
                 End If
                 If temp = a(i, 2) Then txt = txt & "," & temp
             Next
            If txt = "" Then Exit Do 
         Loop
     End With
     [h1].Resize(UBound(a, 1), UBound(a, 2)) = a
 End Sub
(seiya) 2019/01/18(金) 14:55

 seiyaさんの見て、自分じゃ絶対思いつかんと、思い知らされました・・・
 私のコードだと無限ループしてしまったので、直す必要がありそうです。

 んで、いくつかテストして
 3,4行目の矢印の元Qiを「3,4,5」から「4,3,5」にしたとき、
 私と異なる結果が出たのですが、seiyaさんのコードだとどう変更すればよいかわかりませんでした・・・。

 後学のためにご解説いただけませんか?

(稲葉) 2019/01/19(土) 11:16


 稲葉さん、久しぶりです。
 条件としては提示データ通りで、各セルには予めソートされたデータが入力されていることです。

 もし、ランダムならばセル内のデータを一旦並べ替えてからになりますね。(メモリー上での話ですが)。
 そうしておかないと、B列(矢印の先Pi)とD列(Pi AND Qi)(実際には変数temp)との比較の段階で面倒ですので。

 ですので私ならArrayListでも使用して、配列内のB列、C列のデータを昇順に並べ替え手からの作業にまります。

(seiya) 2019/01/19(土) 13:16


 稲葉さん

 よく考えたらPatternとtestの列を変えればよさそうな...

                 If a(i, 2) <> "" Then
                     .Pattern = Replace(a(i, 2), ",", "|")
                     For Each m In .Execute(a(i, 3))
                         temp = temp & IIf(temp <> "", ",", "") & m
                     Next
                 End If

                 If a(i, 2) <> "" Then
                     .Pattern = Replace(a(i, 3), ",", "|")
                     For Each m In .Execute(a(i, 2))
                         temp = temp & IIf(temp <> "", ",", "") & m
                     Next
                 End If
(seiya) 2019/01/19(土) 13:32

 seiyaさん お久しぶりです。
 挨拶が遅れ申し訳ございません。

 列を入れ替えたら、出来ました!

 自分でもseiyaさんのコード見ながらせこせこ考えているのですが、2桁の数字になった時
 Pi の時、1,2,6,12
 Pattern  1|2|3
 だとできないなーとか考えて、
 Pattern \b(1|2|3)\b
 ならどうか?と考えては全部やり直しの繰り返しです。

                     For Each m In .Execute(a(i, 3))
                         temp = temp & IIf(temp <> "", ",", "") & m
                     Next

 この部分も、なんでRegExpのReplace使わないんだろうと疑問ばかりです・・・。

(稲葉) 2019/01/19(土) 14:55


 その部分はマッチした数値のみを抽出しているので、Replaceだとちょっと無理だと思うのですが?
(seiya) 2019/01/19(土) 15:11

 あ、そうでした。
 自分が否定でReplaceしていたのを、失念してました。
 またF8連打する作業に戻ります。。。

 またわからないところがあれば教えてください。

(稲葉) 2019/01/19(土) 15:19


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.