| |
▼ひろし さん：
やっとエクセルのアル環境に戻ってきました。
で、とりあえずコンパイルしてみますと、案の定、たいむぴすがずいぶんありました。
アップしたSampleの改訂版と、そのつど、任意に順番を規定したいとの要件ですので
kanabunさんの案を踏襲して、"Order"というシートのＡ列に任意の数の任意の順番の
クラブ名を登録しそれを参照するSample2を。
いずれも、元データは"Sheet1"、それを転移するシートを"Sheet2"としています。
Sub Sample()
Dim club As Variant
Dim dicV() As Object
Dim z As Long
Dim i As Long
Dim c As Range
Dim x As Variant
Application.ScreenUpdating = False
club = Array("バスケ部", "野 球部", "バレー部", "テニス部")
z = UBound(club) + 2
ReDim dicV(1 To z)
For i = 1 To z
Set dicV(i) = CreateObject("Scripting.Dictionary")
Next
With Sheets("Sheet1")
For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
x = Application.Match(c.Value, club, 0)
If Not IsNumeric(x) Then x = UBound(dicV)
dicV(x)(c.Value) = c.Offset(, 1).Value
Next
End With
z = 1
With Sheets("Sheet2")
.Cells.Clear
For i = 1 To UBound(dicV)
If dicV(i).Count > 0 Then
.Cells(z, 1).Resize(dicV(i).Count).Value = _
Application.Transpose(dicV(i).Keys)
.Cells(z, 2).Resize(dicV(i).Count).Value = _
Application.Transpose(dicV(i).Items)
.Cells(z, 1).Resize(dicV(i).Count, 2).BorderAround xlContinuous
z = z + dicV(i).Count + 1
End If
Next
End With
Erase dicV
Application.ScreenUpdating = True
End Sub
Sub Sample2()
Dim club As Variant
Dim dicV() As Object
Dim z As Long
Dim i As Long
Dim c As Range
Dim x As Variant
Application.ScreenUpdating = False
With Sheets("Order")
club = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Value
End With
z = UBound(club, 1) + 1
ReDim dicV(1 To z)
For i = 1 To z
Set dicV(i) = CreateObject("Scripting.Dictionary")
Next
With Sheets("Sheet1")
For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
x = Application.Match(c.Value, club, 0)
If Not IsNumeric(x) Then x = UBound(dicV)
dicV(x)(c.Value) = c.Offset(, 1).Value
Next
End With
z = 1
With Sheets("Sheet2")
.Cells.Clear
For i = 1 To UBound(dicV)
If dicV(i).Count > 0 Then
.Cells(z, 1).Resize(dicV(i).Count).Value = _
Application.Transpose(dicV(i).Keys)
.Cells(z, 2).Resize(dicV(i).Count).Value = _
Application.Transpose(dicV(i).Items)
.Cells(z, 1).Resize(dicV(i).Count, 2).BorderAround xlContinuous
z = z + dicV(i).Count + 1
End If
Next
End With
Erase dicV
Application.ScreenUpdating = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
