| |
▼ザ 焼鳥男 さん：
こんにちは、
>マクロ手順
>１、まずsheet1とsheet2がありsheet2を、新たに、新しいsheetにコピーして、タグ名を、「result」にします。
>２、sheet1のA列とsheet2のB列の番号を、比較して、同じ番号だけを残します。
>３、「result」のＣ列に、sheet１のB列（名前）の必要部分のみをコピーします。
>４、「result」のNoを、１から連番にします。
>
>１は
> Worksheets("Sheet2").Copy after:=Worksheets("Sheet2")
> ActiveSheet.Name = "RESULT"
>で、よいでしょう。
>
>しかし、２がわかりません。１つのsheet内での、重複比較は、本に載っていますが、別のシートの比較方法が不明なためです。
>
>３は、難解で、全く、解らないです。
>
>Sheet1
>No. 名前 性別
>B01 石川 女
>B02 森田 男
>A01 梅尾 女
>A02 福田 男
>
>
>Sheet2
>番号 No. 住所 年齢 特徴
>
>1 Ａ03 アメリカ １９歳 数学が得意
>2 Ａ04 長野 １９歳 数学が得意
>3 Ａ01 東京 １９歳 国語が得意
>4 Ａ02 鹿児島 １９歳 国語、英語、数学、運動が得意
>
>
>ほしい結果（result）
>番号 No. 住所 名前 年齢 特徴
>
>1 Ａ01 東京 梅尾 １９歳 国語が得意
>2 Ａ02 鹿児島 福田 １９歳 国語、英語、数学、運動が得意
データは正しく書きましょう・上記の場合全部不一致ですよ。
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
|
|
Yuki
- 14/5/18(日) 8:42 -
