|
▼ザ 焼鳥男 さん:
前回の応用で出来ます。
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("Sheet11")
v = .Range("A1").CurrentRegion.Value
End With
' Dictionary に登録
Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(v)
Dic(v(i, 1)) = i
Next
sht.Cells(1, 1).Resize(, 9).Value = Array( _
"ナンバー", "ネーム", "相対的強さ", "ボゾン質量", _
"関連力", "方程式", "到達距離", "関係者", "備考")
eRow = 1
With Worksheets("Sheet12")
For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
' Dictionary の登録とあえば
If Dic.Exists(.Cells(i, 1).Value) Then
' 行番号を追加してコピペ
eRow = eRow + 1
.Cells(i, 1).Resize(, 2).Copy sht.Cells(eRow, 1)
Worksheets("Sheet11").Cells(Dic(.Cells(i, 1).Value), 3).Copy sht.Cells(eRow, 3)
.Cells(i, 4).Resize(, 6).Copy sht.Cells(eRow, 4)
End If
Next
End With
End Sub
|
|