|
▼ザ 焼鳥男 さん:
こんにちは、
>マクロ手順
>1、まずsheet1とsheet2がありsheet2を、新たに、新しいsheetにコピーして、タグ名を、「result」にします。
>2、sheet1のA列とsheet2のB列の番号を、比較して、同じ番号だけを残します。
>3、「result」のC列に、sheet1のB列(名前)の必要部分のみをコピーします。
>4、「result」のNoを、1から連番にします。
>
>1は
> Worksheets("Sheet2").Copy after:=Worksheets("Sheet2")
> ActiveSheet.Name = "RESULT"
>で、よいでしょう。
>
>しかし、2がわかりません。1つのsheet内での、重複比較は、本に載っていますが、別のシートの比較方法が不明なためです。
>
>3は、難解で、全く、解らないです。
>
>Sheet1
>No. 名前 性別
>B01 石川 女
>B02 森田 男
>A01 梅尾 女
>A02 福田 男
>
>
>Sheet2
>番号 No. 住所 年齢 特徴
>
>1 A03 アメリカ 19歳 数学が得意
>2 A04 長野 19歳 数学が得意
>3 A01 東京 19歳 国語が得意
>4 A02 鹿児島 19歳 国語、英語、数学、運動が得意
>
>
>ほしい結果(result)
>番号 No. 住所 名前 年齢 特徴
>
>1 A01 東京 梅尾 19歳 国語が得意
>2 A02 鹿児島 福田 19歳 国語、英語、数学、運動が得意
データは正しく書きましょう・上記の場合全部不一致ですよ。
Option Explicit
Sub TESTa()
Dim Dic As Object
Dim v As Variant
Dim i As Long
Dim j As Long
Dim sht As Worksheet
Dim eRow As Long
' result シートのチェック
On Error Resume Next
Set sht = Worksheets("result")
If Err.Number = 0 Then
sht.Cells.ClearContents 'シートがあったらクリア
Else '無かったら追加
Set sht = Worksheets.Add(After:=Worksheets(Worksheets.Count))
sht.Name = "result" '名前を result
End If
On Error GoTo 0
' ******************* 此処まで **************
With Worksheets("Sheet1")
v = .Range("A1").CurrentRegion.Value
End With
' Dictionary に登録
Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(v)
Dic(v(i, 1)) = Empty
Next
eRow = 1
With Worksheets("Sheet2")
.Cells(1, 1).Resize(, 5).Copy sht.Cells(eRow, 1)
For i = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
' Dictionary の登録とあえば
If Dic.Exists(.Cells(i, 2).Value) Then
' 行を追加してコピペ
eRow = eRow + 1
sht.Cells(eRow, 1).Value = eRow - 1
.Cells(i, 2).Resize(, 4).Copy sht.Cells(eRow, 2)
End If
Next
End With
End Sub
|
|