|
▼ace さん:
>
Option Explicit
Sub test()
Dim dic As Object
Dim 見出Sht As Worksheet, 詳細Sht As Worksheet
Dim r As Range, w() As String, v
Dim k As Long
Dim No As String, idx As Long, s1 As String, s2 As String
Set dic = CreateObject("scripting.dictionary")
Set 見出Sht = Worksheets("見出")
Set 詳細Sht = Worksheets("詳細")
Set r = 見出Sht.Columns("E").SpecialCells(xlCellTypeConstants).Resize(, 2)
ReDim w(1 To r.Rows.Count, 1 To 2)
v = r.Value
For k = 1 To UBound(v)
No = v(k, 1) & "_" & v(k, 2) '年度_No,
idx = k
If Not dic.exists(No) Then dic(No) = idx
Next
Set r = 詳細Sht.Columns("E").SpecialCells(xlCellTypeConstants).Resize(, 10)
v = r.Value
v = WorksheetFunction.Sort(v, 3, 1, False) 'G列(SEQ)でソート
For k = 1 To UBound(v)
No = v(k, 1) & "_" & v(k, 2) '年度_No,
If dic.exists(No) Then
idx = dic(No)
s1 = v(k, 9) '項目
s2 = v(k, 10) '結果
s2 = s1 & "(" & s2 & ")"
w(idx, 1) = IIf(w(idx, 1) = "", s1, w(idx, 1) & "," & s1)
w(idx, 2) = IIf(w(idx, 2) = "", s2, w(idx, 2) & "," & s2)
End If
Next
Set r = 見出Sht.Columns("AA:AB")
r.ClearContents
r.Resize(UBound(w)).Value = w
r.AutoFit
End Sub
|
|