[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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 >
>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
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
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.