[[20050305200025]]　『A列とB列で一致するものだけをC列へ』（ラーメン君）　ページの最後に飛ぶ

『A列とB列で一致するものだけをC列へ』（ラーメン君）

A列に100個の項目のあるリストがあります。
B列にも100個の項目のリストがあります。
A列とB列には一部同じものが存在します。

そこで、C列にA列とB列のなかで一致するものだけを
上から順に並べたいです。

このような作業をマクロでIf関数を使って命令する方法を
教えていただけないでしょうか？
よろしくお願いします。

 こんばんは！！
とりあえず、、
Option Explicit
Sub てすと()
Dim MyA As Variant, MyAry() As Variant
Dim x As Variant
Dim i As Long, k As Long
With Worksheets("Sheet1")
    MyA = .Range("A1", .Range("A65536").End(xlUp)).Value
    For i = 1 To UBound(MyA, 1)
        x = Application.Match(MyA(i, 1), .Range("B1", .Range("B65536").End(xlUp)), 0)
        If Not IsError(x) Then
            k = k + 1
            ReDim Preserve MyAry(1 To 1, 1 To k)
            MyAry(1, k) = MyA(i, 1)
        End If
    Next
    .Range("C:C").ClearContents
    .Range("C1").Resize(UBound(MyAry, 2)).Value = Application.Transpose(MyAry)
End With
Erase MyA, MyAry
End Sub
（SoulMan）

SoulManさん、大変ありがとうございます。マクロがしっかりと動きました。
レベルの高いマクロで少し教えて頂けると助かります。下記のところのマクロが
よくわからないのですが。解説をもらえるとうれしいです。

If Not IsError(x) Then

            k = k + 1
            ReDim Preserve MyAry(1 To 1, 1 To k)
            MyAry(1, k) = MyA(i, 1)
        End If
    Next
    .Range("C:C").ClearContents
    .Range("C1").Resize(UBound(MyAry, 2)).Value = Application.Transpose(MyAry)
End With
Erase MyA, MyAry

 >レベルの高いマクロで
 全然、高くないっす。。簡単っす。。すぐに出来る様になります。。
Option Explicit
Sub てすと()
Dim MyA As Variant, MyAry() As Variant
Dim x As Variant
Dim i As Long, k As Long
With Worksheets("Sheet1")
    '配列に値を取得
    MyA = .Range("A1", .Range("A65536").End(xlUp)).Value
    '上限までループ
    For i = 1 To UBound(MyA, 1)
        'Matchであるか判断
        x = Application.Match(MyA(i, 1), .Range("B1", .Range("B65536").End(xlUp)), 0)
        'あったら（エラーじゃなかったら）
        If Not IsError(x) Then
        '配列を拡張しながらデータを追加
            k = k + 1
            ReDim Preserve MyAry(1 To 1, 1 To k)
            MyAry(1, k) = MyA(i, 1)
        End If
    Next
    '出力先をクリア
    .Range("C:C").ClearContents
    '行と列を入れ替えて出力
    .Range("C1").Resize(UBound(MyAry, 2)).Value = Application.Transpose(MyAry)
End With
'変数のクリア
Erase MyA, MyAry
End Sub
（SoulMan）

 我流だけど、配列の拡張とかが難しいんだったら、、そのまま書き換えてもいいし、、
Option Explicit
Sub てすと()
Dim MyA As Variant
Dim i As Long, k As Long
Dim x As Variant
With Worksheets("Sheet1")
    .Range("C:C").ClearContents
    MyA = .Range("A1", .Range("A65536").End(xlUp)).Resize(, 3).Value
    For i = 1 To UBound(MyA, 1)
        x = Application.Match(MyA(i, 1), .Range("B1", .Range("B65536").End(xlUp)), 0)
        If Not IsError(x) Then
        k = k + 1
        MyA(k, 3) = MyA(i, 1)
    End If
    Next
    .Range("A1", .Range("A65536").End(xlUp)).Resize(, 3).Value = MyA
End With
Erase MyA
End Sub
なんなら、、Findであるかないか調べてもいいし、、
Sub てすと()
Dim C As Range, MyTbl As Range
Dim i As Long, k As Long
With Worksheets("Sheet1")
    Set MyTbl = .Range("B1", .Range("B65536").End(xlUp))
    .Range("C:C").ClearContents
    For i = 1 To .Range("A65536").End(xlUp).Row
        Set C = MyTbl.Find(Cells(i, 1), , xlValues, xlWhole, xlByColumns, xlNext, True)
        If Not C Is Nothing Then
            k = k + 1
            .Cells(k, 3).Value = C.Value
        End If
    Next
End With
Set C = Nothing
Set MyTbl = Nothing
End Sub
方法は、、色々ありそうです。。
（SoulMan）

 もうひとつ。。わかりやすいいなら、、こんな感じの方が分かりやすいかな？？
Option Explicit
Sub てすと()
Dim MyA() As Variant, MyAry() As Variant
Dim C As Range, R As Range
Dim k As Long, i As Long
With Worksheets("Sheet1")
    .Range("C:C").ClearContents
    For Each C In .Range("A1", .Range("A65536").End(xlUp))
        For Each R In .Range("B1", .Range("B65536").End(xlUp))
            If C.Value = R.Value Then
                k = k + 1
                ReDim Preserve MyA(1 To k)
                MyA(k) = C.Value
            End If
        Next
    Next
    ReDim MyAry(1 To k, 1 To 1)
    For i = 1 To UBound(MyA, 1)
        MyAry(i, 1) = MyA(i)
    Next
    .Range("C1").Resize(UBound(MyAry, 1)).Value = MyAry
End With
Erase MyA, MyAry
End Sub
（SoulMan）

 おはようございます。朝起きたら一番得意な方法を忘れておりました。
Option Explicit
Sub てすと()
Dim MyDic As Object
Dim MyA As Variant, MyAry() As Variant
Dim MyKey As String
Dim i As Long, k As Long
Set MyDic = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
    .Range("C:C").ClearContents
    MyA = .Range("A1").CurrentRegion.Value
    ReDim MyAry(1 To UBound(MyA, 1), 1 To 1)
    For i = 1 To UBound(MyA, 1)
        MyKey = MyA(i, 2)
        If Not MyDic.Exists(MyKey) Then MyDic.Add MyKey, Empty
    Next
    For i = 1 To UBound(MyA, 1)
        MyKey = MyA(i, 1)
        If MyDic.Exists(MyKey) Then
            k = k + 1
            MyAry(k, 1) = MyA(i, 1)
        End If
    Next
    If k > 0 Then
        .Range("C1").Resize(k).Value = MyAry
    End If
End With
Erase MyA, MyAry
Set MyDic = Nothing
End Sub
（SoulMan）

SoulManさん、本当にありがとうございます。
たくさんのパターンを考えて頂きまして。
私としては, Findを使ったものが解りやすかったです。
勉強になるので今, 他のマクロも解読中です。
ありがとうございました。

 D1を空白で、D2に=COUNTIF(B$2:B$100,A2)としておき、フィルタをされたらどうでしょう？
 マクロの記録では、このようになります。　　　　　　　　　　　　　　　　　　　　　　　(LOOKUP)

 Sub Macro1()
     Range("A1:A100").AdvancedFilter Action:=xlFilterCopy, _
     CriteriaRange:=Range("D1:D2"), CopyToRange:=Range("C1"), Unique:=False
 End Sub

 　　A　　　B　　　　　C　　　　D
1　項目1　項目2　　 項目1	
2　A10　　 A5　　　　A15　　　　0
3　A15　　 A2　　　　A5　　　　↑	
4　A5　　　A12　　　 A2	=COUNTIF(B$2:B$100,A2)
5　A30　　 A15		
6　A2　　　A18		
7

 おぉぉぉぉ師匠に追われております。。(O.O;)(oo;)
 >Findを使ったものが解りやすかったです。
 ということは、、見えた方がいいのかな？？
一行目から始まらないのが難点だけど、、一行目は大体見出しだからね。。
ということで、、、だんだんネタ切れ(;^_^A あせあせ･･･
もうちょっと、、いく？？？
Option Explicit
Sub てすと()
Dim MyTbl As Range
Dim i As Long, x As Long
With Worksheets("Sheet1")
    .Range("C:C").ClearContents
    Set MyTbl = .Range("B1", .Range("B65536").End(xlUp))
    For i = 1 To .Range("A65536").End(xlUp).Row
        x = Application.WorksheetFunction.CountIf(MyTbl, .Cells(i, 1).Value)
        If x > 0 Then
            .Range("C65536").End(xlUp).Offset(1).Value = .Cells(i, 1).Value
        End If
    Next
End With
Set MyTbl = Nothing
End Sub
（SoulMan）

 動きが見えた方がいいということでしたら、、
これなんかどうでしょうか？？
F8で一つ一つステップしてください。。。
Option Explicit
Sub てすと()
Dim i As Long
Dim x As Variant
With Worksheets("Sheet1")
    .Range("C:C").ClearContents
    .Range("A1", .Range("A1").End(xlDown)).Copy Destination:=.Range("C1")
    For i = 1 To .Range("C65536").End(xlUp).Row
        x = Application.Match(.Cells(i, 3), .Range("B1", .Range("B65536").End(xlUp)), 0)
        If IsError(x) Then
            .Cells(i, 3).Value = ""
        End If
    Next
    On Error Resume Next
    .Range("C1", .Range("C65536").End(xlUp)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    On Error GoTo 0
End With
End Sub
（SoulMan）

F8でステップインしてみるとよく動きが解かりました。
今回の件でいろいろとマクロのことが解かりました。
SoulManさん、本当にありがとうございます。

コメント返信：

[ 一覧(最新更新順) ]

[[20050305200025]] 『A列とB列で一致するものだけをC列へ』（ラーメン君） ページの最後に飛ぶ

[[20050305200025]]　『A列とB列で一致するものだけをC列へ』（ラーメン君）　ページの最後に飛ぶ