ここから本文です

EXCEL・VBA 2つの配列の要素を比較し、足りない要素を抽出する方法を教えてくださ...

アバター

ID非公開さん

2018/6/2915:33:26

EXCEL・VBA 2つの配列の要素を比較し、足りない要素を抽出する方法を教えてください。

2つの配列があります。
配列の要素数は異なります。

Array1 = Array("a", "b", "c", "c")
Array2 = Array("a", "c")

この2つの配列でArray1にあって、Array2に無い要素を抽出するVBAを書きたいのですが(上記の場合、bと2つ目のcを出したい)、やり方がわかりません。

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

※不足を確認するだけなら下記のようなスクリプトを思いつきました

Sub Sample()
Dim Array1() As Variant
Dim Array2() As Variant
Dim x As Boolean
Dim i As Long

Array1 = Array("a", "b", "c", "c")
Array2 = Array("a", "c")

x = True
For i = LBound(Array1) To UBound(Array1)
If Array1(i) <> Array2(i) Then
x = False
Exit For
End If
Next i
If x = True Then
Debug.Print "一致"
Else
Debug.Print "不足:" & i
End If

End Sub

補足皆様ご回答ありがとうございます。
大変勉強になります。

Array1とArray2の要素数は

Array1 = Array("a", "d")
Array2 = Array("a", "b", "c", "c")
※この場合はdを抽出

Array1 = Array("a","b", "d", "d")
Array2 = Array("a", "b", "c", "c")
※この場合は1つ目のdと二つ目のdを抽出

のように一定ではありません。
また要素の順番は関係なく、単にArray1にあってArray2に足りない要素を出したく思います。
よろしくお願いいたします。

閲覧数:
1,668
回答数:
7
お礼:
500枚

違反報告

ベストアンサーに選ばれた回答

msk********さん

2018/6/2916:30:04

一例です。

Sub Sabmple()
Dim Array1, Array2, i As Long, j As Long
Array1 = Array("a", "b", "c", "c")
Array2 = Array("a", "c")
For j = LBound(Array2) To UBound(Array2)
For i = LBound(Array1) To UBound(Array1)
If Array2(j) = Array1(i) Then
Array1(i) = 0
Exit For
End If
Next i, j
Array1 = Filter(Array1, 0, False)
MsgBox Join(Array1, ",")
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

アバター

質問した人からのコメント

2018/7/4 14:56:33

どれも甲乙つけがたい回答ばかりでしたが、一番シンプルなコードを書いてくださったmsk********様をベストアンサーとさせていただきます。
この度はありがとうございました。

ベストアンサー以外の回答

1〜5件/6件中

並び替え:回答日時の
新しい順
|古い順

30246kikuさん

2018/7/118:02:40

参考になるところがあれば・・・・

データ量が多くないと、面白くないので・・・・

Array1 ・・・ A1 ~ A 最終行
Array2 ・・・ B1 ~ B 最終行
として、結果を C1 ~ 書き出します

確認は

新規ブックを開き、標準モジュールに以下を記述します
testData で確認用データを作成後、
testData2 や Samp1 を実行してみます

testData → testData2 → Samp1 とか
testData → Samp1 → testData2 とか

testData で作成するデータの並び順は
#Const mySort = True ⇔ #Const mySort = False
の指定で切り替わりますが、
昇順にしていないと testData2 の結果はおかしくなります
昇順にしていなかった時の確認は、
Samp1 実行後出来上がった A ~ C 列を1列ずつ昇順に並び替えた後、
testData2 実行で確認しやすくなるかと・・・・

testData2 を実行すると、A, B 列を揃えた表示にしてくれるので
C 列の結果確認は容易??・・・・(B 列空白の A 列のものが C 列に・・・)

Samp1 でやっていることは

B 列に出現したものと、その個数を Dictionary に覚えておきます
A 列のデータを入手したら、順に
・Dictionary に覚えているか・・・・
覚えていなかったら、上から詰め直す様に・・・・
覚えていたら、
個数 - 1 して・・・・ 結果 < 1 になったら忘れる
でなかったら、あと何個ある・・・・覚えなおす

最終的に、上に詰め直した分だけを C 列に書き出して終わり



Option Explicit

' testData での並び順を昇順に、 Samp1 の動作には不要
#Const mySort = True

Public Sub Samp1()
   Dim dic As Object
   Dim vA As Variant
   Dim i As Long, j As Long, k As Long

   Set dic = CreateObject("Scripting.Dictionary")

   With ActiveSheet
      With .Range("B1", .Cells(Rows.Count, "B").End(xlUp))
         vA = .Value
      End With
      For i = 1 To UBound(vA)
         If (vA(i, 1) <> "") Then dic(vA(i, 1)) = dic(vA(i, 1)) + 1
      Next

      With .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
         vA = .Value
         k = 0
         For i = 1 To UBound(vA)
            If (vA(i, 1) <> "") Then
               If (Not dic.Exists(vA(i, 1))) Then
                  k = k + 1
                  vA(k, 1) = vA(i, 1)
               Else
                  j = dic(vA(i, 1)) - 1
                  If (j < 1) Then
                     dic.Remove vA(i, 1)
                  Else
                     dic(vA(i, 1)) = j
                  End If
               End If
            End If
         Next
         With .Offset(, 2)
            .ClearContents
            If (k > 0) Then .Resize(k).Value = vA
         End With
      End With
   End With

   Set dic = Nothing
End Sub



' 確認用データ作成

Public Sub testData()
   Const CRH As Long = 1000
   Dim vA(1 To CRH, 1 To 2) As Variant
   Dim sS As String
   Dim i As Long, j As Long, k As Long
   Const CMC As Long = 2 ' 文字数

   Randomize

   For i = 1 To CRH
      For j = 1 To 2
         sS = ""
         For k = 1 To CMC
            sS = sS & Chr(Asc("A") + Int(26 * Rnd()))
         Next
         vA(i, j) = sS
      Next
   Next

   Application.ScreenUpdating = False
   Cells.Delete
   With Range("A1").Resize(CRH, 2)
      .Value = vA
#If (mySort) Then
      For j = 1 To 2
         With .Columns(j)
            .Sort .Cells(1), xlAscending, Header:=xlNo
         End With
      Next
#End If
   End With
'   Call testData2
   Application.ScreenUpdating = True
End Sub


Private Sub testData2()
   Dim vA As Variant, vR As Variant
   Dim i As Long, j As Long, k As Long, n As Long

   n = Cells(Rows.Count, "A").End(xlUp).Row
   i = Cells(Rows.Count, "B").End(xlUp).Row
   If (n < i) Then n = i

   vA = Range("A1").Resize(n, 2).Value
   ReDim vR(1 To n * 2, 1 To 2)
   i = 1: j = 1: k = 0

   While ((i <= n) And (j <= n))
      k = k + 1
      If ((vA(i, 1) <> "") And (vA(j, 2) <> "")) Then
         If (vA(i, 1) < vA(j, 2)) Then
            vR(k, 1) = vA(i, 1)
            i = i + 1
         ElseIf (vA(i, 1) > vA(j, 2)) Then
            vR(k, 2) = vA(j, 2)
            j = j + 1
         Else
            vR(k, 1) = vA(i, 1)
            vR(k, 2) = vA(j, 2)
            i = i + 1: j = j + 1
         End If
      ElseIf (vA(i, 1) <> "") Then
         vR(k, 1) = vA(i, 1)
         i = i + 1: j = j + 1
      Else
         vR(k, 2) = vA(j, 2)
         i = i + 1: j = j + 1
      End If
   Wend

   Range("A1").Resize(k, 2).Value = vR
End Sub



※ 余談

testData2 の処理は、以下の Samp2 そのものです

Excelのデータで Aセル、Bセルにそれぞれ 1,1 2
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q121924634...

だるまさん

2018/6/3020:31:58

配列どうしの比較などという【よく行われる処理】
に対しては、私は汎用のプログラムを作ってあり、
その都度一々コードを書くなどという事は、
基本的にしません。

配列のソートなどに関しても同様です。

で、それらのプログラムをここで提示できれば
良いのですが、残念ながらそれらをまとめたもの
は既にシェアウエアとして公開している為、
ここで紹介するわけには行きません。

という事で、全然回答になっていないコードに
なってしまうのですが、仮にそのプログラム
(クラス化してあります。)を利用すると、
こんな感じになりますという、コードの紹介です。

もし興味がありましたら私のHPの中などから
探してみてください。^d^
(直接のリンクはルール違反のようですので。)


Sub Sample()
    Dim cMA As cMatchArray
    Dim Array1, Array2
    Dim V
    
    '配列比較クラスのインスタンス生成
    Set cMA = SourceOfAddin.GetClass.MatchArrayClass
    
    Array1 = Array("a", "b", "c", "c")
    Array2 = Array("a", "c")
    
    With cMA
        '比較実行
        .MatchArray Array1, Array2
        
        '第一引数側に不一致(余り)があれば
        If .ExistUnMatchA Then
            For Each V In .UnMatchA
                Debug.Print V
            Next
            
        Else
            Debug.Print "なし"
        End If
    End With
    
    Set cMA = Nothing
End Sub





参考になるかもしれない、エクセルVBA小技集
http://hp.vector.co.jp/authors/VA033788/kowaza.html

hig********さん

2018/6/3001:34:01

質問文はi=1でたまたま一致してないだけで、不足判定しちゃってます。判断早過ぎです。
array1(1)がarray2(1)〜array2(5)にあるか調べ、判定
arry1(2)がarray2(1)〜array2(5)にあるか調べ、判定
arry1(3)がarray2(1)〜array2(5)にあるか調べ、判定
何となく想像付くと思いますが、2重ループを使います。

で、問題はarray1に重複データがあっても個数まで判定するにはどうするか?不足してないアリ判定が下ったら、array2から削除するのです。そうすれば2個目のCは無事に不足判定されます。実際に配列要素を削除するのは厄介なので、あり得ない文字列に変更します。

For i = LBound(Array1) To UBound(Array1)
x= false
for j=LBound(Array2) To UBound(Array2)
If Array1(i) =Array2(j) Then
x = true
array2(j)="Arienaiiiii"
Exit For
End If
next j
If x = false Then
Debug.Print "不足:" & i
End If
next i

プロフィール画像

カテゴリマスター

nora1962jpさん

2018/6/2917:42:27

> この2つの配列でArray1にあって、Array2に無い要素を抽出するVBAを書きたいのですが(上記の場合、bと2つ目のcを出したい)

たとえば
Array1 = Array("a", "b", "c", "c","b","c")
Array2 = Array("a", "b", "c", "c")

の時どう出力したいのですか?
「Array2に重複する要素はない」ことが前提でしょうか。
加えてArray1に重複した要素があった場合はArray2に一致するものがあっても2個目以降は抽出対象とする、でいいのか。

あとArray1とArray2の要素の順序によって結果が異なる場合はあるのか
Array1 = Array("a", "b", "c", "c","b","c")
Array2 = Array("a", "c", "b")

など

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

2018/6/2916:59:11

Sub Sabmple()
Dim Array1 As Variant
Dim Array2 As Variant
Dim Array3() As String
Dim i As Long
Dim j As Long
Dim SearchF As Boolean

Array1 = Array("a", "b", "c", "c")
Array2 = Array("a", "c")
ReDim Array3(0)

For i = LBound(Array1) To UBound(Array1)
SearchF = False
For j = LBound(Array2) To UBound(Array2)
If Array2(j) = Array1(i) Then
Array2(j) = vbNullString
SearchF = True
Exit For
End If
Next j
If Not SearchF Then
ReDim Preserve Array3(UBound(Array3) + 1)
Array3(UBound(Array3)) = i + 1 & "番目の" & Array1(i)
End If
Next i

MsgBox Join(Array3, vbCrLf)
End Sub

あわせて知りたい

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる