| |
▼ドカ さん：
出発前に時間が取れたので、シートを見ながら、手作業で切り貼りや並び替えやセルの挿入をする
そんな流れをコードにしてみました。
処理効率、かなり悪くなりますが、操作とコードが一致しているので、理解しやすいかもしれません。
先にアップしたものは、元シートの列の左から右に、名前の出現順の並びでしたが、こんどのものは
名前の昇順になります。
Sub Sample2()
Dim blocks As Long
Dim x As Long
Dim y As Long
Dim wkCol1 As Long
Dim wkCol2 As Long
Dim j As Long
Dim i As Long
Dim k As Long
Dim n As Long
Dim c As Range
Dim v() As Long
Dim z As Long
Application.ScreenUpdating = False
With Sheets("Sheet2")
'準備作業
Sheets("Sheet1").Cells.Copy .Range("A1") 'Sheet1をSheet2にコピー
With .Range("A1").CurrentRegion
x = .Columns.Count '表の列数
y = .Rows.Count '表の行数
End With
blocks = x \ 3
wkCol1 = x + 2
wkCol2 = wkCol1 + 2
'各ブロックの名前列を作業列1にセットするとともに、名前順に並び替え
i = 1
For j = 1 To blocks
k = (j - 1) * 3 + 1 'ブロックの名前列番号
n = .Cells(.Rows.Count, k).End(xlUp).Row 'ブロックの名前列の最終行番号
.Cells(i, wkCol1).Resize(n).Value = .Cells(1, k).Resize(n).Value
.Columns(k).Resize(, 3).Sort Key1:=.Columns(k), Order1:=xlAscending, Header:=xlYes
i = i + n
Next
'この名前から重複を排除し作業列2に抽出
.Cells(1, wkCol1).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, wkCol2), Unique:=True
'作業列2を名前順に並び替え
.Columns(wkCol2).Sort Key1:=.Columns(wkCol2), Order1:=xlAscending, Header:=xlYes
'作業列2から名前を取り出して処理開始
i = 2 '表のデータ開始行
For Each c In .Cells(1, wkCol2).CurrentRegion
If c.Value <> .Range("A1").Value Then '名前タイトル文字ならスキップ
ReDim v(1 To blocks)
z = 0
For j = 1 To blocks
k = (j - 1) * 3 + 1 'ブロックの名前列番号
n = .Cells(.Rows.Count, k).End(xlUp).Row 'ブロックの名前列の最終行番号
v(j) = WorksheetFunction.CountIf(.Columns(k), c.Value) 'この列のこの名前の個数
If v(j) > z Then z = v(j) '全体のこの名前の個数の最大値
Next
For j = 1 To blocks
k = (j - 1) * 3 + 1 'ブロックの名前列番号
n = 0
If .Cells(i, k).Value <> c.Value Then
n = z
Else
n = z - v(j)
End If
If n > 0 Then
.Cells(i + v(j), k).Resize(n, 3).Insert Shift:=xlDown
End If
Next
i = i + z
End If
Next
.Cells(1, wkCol1).CurrentRegion.Clear '作業列1のクリア
.Cells(1, wkCol2).CurrentRegion.Clear '作業列2のクリア
.Select
End With
Application.ScreenUpdating = True
MsgBox "転記完了です"
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
