| |
▼ace さん：
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("D").SpecialCells(xlCellTypeConstants).Resize(, 3)
ReDim w(1 To r.Rows.Count, 1 To 3)
v = r.Value
For k = 1 To UBound(v)
No = v(k, 1) & "_" & v(k, 2) & "_" & v(k, 3) '証区分_年度_No,
idx = k
If Not dic.exists(No) Then dic(No) = idx
Next
Set r = 詳細Sht.Columns("D").SpecialCells(xlCellTypeConstants).Resize(, 11)
With r.Offset(, 9999) '右側の空き領域を作業セルとして使用
.Value = r.Value
.Sort .Columns(4)
v = .Value
.Clear
End With
For k = 1 To UBound(v)
No = v(k, 1) & "_" & v(k, 2) & "_" & v(k, 3) '証区分_年度_No,
If dic.exists(No) Then
idx = dic(No)
s1 = v(k, 10) '項目
s2 = v(k, 11) '結果
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
Set r = 見出Sht.Columns("A")
r.Resize(UBound(w)).Formula = "=text(h1,""yy/mm"")&p1"
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
