| |
こんにちは。
質問はよく考えて追加しないように解答者にとっては2重になりますから。
ついでに性別も追加できるようにしておきました。
使う場合は性別無しの下の行をコメントにして
性別有りの下の行をコメントを外してください。
御自分の質問だけでなく他の質問者の内容もチェックして
自分だったらどう考えるかなとかしてみましょう。
実践的で勉強になると思います。
よそのサイトですが
//www.moug.net/faq/viewforum.php?f=2
も参考にしてみられては。
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)) = i
Next
' 性別有り ***** この↓１行
' sht.Cells(1, 1).Resize(, 7).Value = Array("番号", "No.", "名前", "性別", "住所", "年齢", "特徴")
' 性別無し ***** この↓１行
sht.Cells(1, 1).Resize(, 6).Value = Array("番号", "No.", "名前", "住所", "年齢", "特徴")
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(, 1).Copy sht.Cells(eRow, 2)
'性別有り ***** この↓ 2行
' Worksheets("Sheet1").Cells(Dic(.Cells(i, 2).Value), 2).Resize(, 2).Copy sht.Cells(eRow, 3)
' .Cells(i, 3).Resize(, 3).Copy sht.Cells(eRow, 5)
'性別無し ***** この↓ 2行
Worksheets("Sheet1").Cells(Dic(.Cells(i, 2).Value), 2).Resize(, 1).Copy sht.Cells(eRow, 3)
.Cells(i, 3).Resize(, 3).Copy sht.Cells(eRow, 4)
End If
Next
End With
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
