|
▼はる さん:
それでは以下でお試しください。
Sub Sample6()
Dim wkR As Range
Dim myR As Range
Dim y As Long
Dim v() As Variant
Dim dic As Object
Dim c As Range
Dim i As Long
Dim j As Long
With Sheets("Sheet1")
y = .Range("A" & .Rows.Count).End(xlUp).Row
Set myR = .Range("A7:G" & y) '左側のデータ域
Set wkR = myR.Columns(7) 'G列作業域
wkR.Formula = "=IF(F7=0,1,0)"
wkR.Value = wkR.Value
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=wkR, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.Columns("A"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange myR
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ReDim v(1 To y - 6, 1 To 5) '右側領域用配列
Set dic = CreateObject("Scripting.Dictionary")
For Each c In .Range("A7:A" & y) '並び替えられたA列
dic(c.Value) = dic.Count + 1 '1から順番に配列内行番号を割り振る
Next
For Each c In .Range("H7:H" & y) '右側領域の人名セル抽出
If dic.exists(c.Value) Then 'もし左側領域にあれば
i = dic(c.Value) '配列に納めるべき行番号
For j = 1 To 5 'H列〜L列
v(i, j) = c.Offset(, j - 1).Value
Next
End If
Next
.Range("H7").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End With
wkR.Clear
End Sub
|
|