ここから本文です

無限ループを使用せずに、短時間で2つのリストを照らし合わせるマクロ 2つの類...

msm********さん

2018/9/1300:04:25

無限ループを使用せずに、短時間で2つのリストを照らし合わせるマクロ

2つの類似したリストがあり、それぞれ内容が少し異なったり、行数が違うものがあります。

例:
ListA
A B C
1 a*

2 b *
2 c *
3 a *
3 d *


ListB
A B C
1 a *
2 b *
2 c *
2 d *
3 a *


List要約:ListAの方にはA列3のものが1つ多く、ListBのA列2のものが1つ多いです。

このうち、ListAとListBのA列andB列が完全一致する、完全一致するものがないかを探すマクロを作成したいです。
無限ループの中に無限ループを仕込むことで実現することができましたが、とても時間がかかります。

私のサンプルを下記に貼っています。
なんとか短期間で確認するものを作ることができないでしょうか。
素人考えですが、少なくともA列が昇順でないと実現できないと思いますので、A列は昇順になっているものとしてください。
また、完全一致するものは有るとしたら1つしかないという条件でかまいません。
(可能であれば、一度一致したものは確認対象としない条件が有るものと無いものマクロサンプルを作って頂きたいです。)

マクロが得意な方がいらっしゃいましたら、お力を貸してください!
よろしくお願いいたします。

Sub ListAにある物がListBにあるかを判別し、記録する()

a = 1
b = 1
label01:

Do Until Worksheets("ListA").Range("A" & a).Value = ""

Do Until Worksheets("ListB").Range("A" & b).Value = ""
If Worksheets("ListA").Range("A" & a).Value = Worksheets("ListB").Range("A" & b).Value and Worksheets("ListA").Range("B" & a).Value = Worksheets("ListB").Range("B" & b).Value Then

命令:一致するものがあった旨を、該当のListAに印をつける。
a = a +1
b = 1
GoTo label01

Else
b = b + 1

End If

Loop
命令:一致するものがなかった旨を、該当のListAに印をつける。
a = a +1
b = 1

Loop

End Sub

閲覧数:
124
回答数:
3
お礼:
50枚

違反報告

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

kik********さん

2018/9/1307:42:06

以下でどうなりますか

標準モジュールに以下を記述し、Samp1 を実行してみます
確認用データが必要なら、testData を実行すれば・・・・

ある/ない を処理する時には Dictionary を使うと楽で、しかも速いです
ListB で、1つの文字列にしたパターンを
      dic(vA(i, 1) & CSP & vA(i, 2)) = "一致"
で Dictionary に覚えて、
            vA(i, 1) = dic(vA(i, 1) & CSP & vA(i, 2))
で、覚えていたものを取り出す
覚えていたパターンなら "一致" が、
覚えていなかったら、Empty値 が得られるので・・・
1列目に設定し直して、1列目だけを一気に書出し

この処理では、一致するものがなかったら空欄のままになりますが、
一致したら ○、じゃなかったら × とするのなら以下変更で

            vA(i, 1) = dic(vA(i, 1) & CSP & vA(i, 2))

            If (dic.Exists(vA(i, 1) & CSP & vA(i, 2))) Then
               vA(i, 1) = "○"
            Else
               vA(i, 1) = "×"
            End If

1つの文字列にしたパターンを覚えていたら ○ ・・・・

なお、結果は一気に書き出しているので、
Application.ScreenUpdating
の記述は不要です・・・・

※ 提示あったのは True / False 逆ですね


どうなりますか


Option Explicit

Public Sub Samp1()
   Dim dic As Object
   Dim vA As Variant
   Dim i As Long
   Const CSP As String = vbTab

   Set dic = CreateObject("Scripting.Dictionary")

   With Worksheets("ListB")
      With .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
         vA = .Resize(, 2).Value
      End With
   End With
   For i = 1 To UBound(vA)
      dic(vA(i, 1) & CSP & vA(i, 2)) = "一致"
   Next

   With Worksheets("ListA")
      With .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
         vA = .Resize(, 2).Value
         For i = 1 To UBound(vA)
            vA(i, 1) = dic(vA(i, 1) & CSP & vA(i, 2))
         Next
         .Offset(, 2).Value = vA
      End With
   End With

   Set dic = Nothing
End Sub


' 確認用データ作成

Public Sub testData()
   Dim vA As Variant, v As Variant
   Dim sS As String
   Dim i As Long, j As Long, k As Long, n As Long

   Randomize

   n = Val(InputBox("何行 ?", , 1000))
   If (n < 10) Then Exit Sub

   For Each v In Array("ListA", "ListB")
      ReDim vA(1 To n, 1 To 2)
      i = 1
      j = 1
      While (i <= n)
         k = Int(26 * Rnd())
         If (n < i + k) Then k = n - i
         For k = 0 To k
            vA(i + k, 1) = j
            vA(i + k, 2) = Chr(Asc("a") + k)
         Next
         j = j + 1
         i = i + k
      Wend
      With Worksheets(v)
         .Cells.Delete
         .Range("A1").Resize(n, 2).Value = vA
      End With
   Next
End Sub

この質問は投票によってベストアンサーに選ばれました!

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

1〜2件/2件中

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

ys1********さん

2018/9/1510:37:51

msm********さん、
ありがとうございます。
早速、使ってみます。

今までは ホスト系の PL/I,COBOLでプログラムを作成していました。
基本、ホストでやれる事は VBAでもやれるという前提で、どう表現すれば
良いのかが課題で、質問しました。

これからもよろしくお願いします。

プロフィール画像

カテゴリマスター

tra********さん

2018/9/1301:12:20

>無限ループの中に無限ループを仕込むことで実現することができました
あなたのコードは、無限ループじゃないです。
Loopが終了する条件を満たすことができますよね?
終了条件を満たすことができない繰り返し処理のことを無限ループといいます。
たとえば
Do Until 1 = 3
といった繰り返し処理です。
プログラマーにとっては鬼門の用語です。

ListAにある物がListBにあるか否かを判別したいだけなら、COUNTIFS関数を使えば存在の有無は検査できます。

Sub sample()
Dim rngAB As Range, rng As Range
Application.ScreenUpdating = True
Set rngAB = Worksheets("ListB").Range("A:B")
With Worksheets("ListA")
With .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
.Offset(, 2).Value = "ListBにありません"
For Each rng In .Cells
With rng
If WorksheetFunction.CountIfs(rngAB.Columns(1), .Value, _
rngAB.Columns(2), .Offset(, 1).Value) > 0 Then
.Offset(, 2).Value = "ListBにあります"
End If
End With
Next rng
End With
End With
Application.ScreenUpdating = False
End Sub

Application.ScreenUpdating は初歩的な高速化の呪文。調べてください。

あわせて知りたい

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

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

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

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

閉じる

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

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

閉じる