| |
▼ドカ さん：
前トピでは、列を取り違えていてごめんなさいね。
さて、｢何か変じゃないですか｣さんのご指摘、その通りだと思います。
思いますが、私も、数日、ＰＣ環境のないところにでかけますので
とりあえず書いたものをアップしておきます。
また、｢こんなわけのわからんコードはお断り｣といわれそうですが。
必要なら、旅から戻った後、前トピのSample3のようなコードも考えてみますが。
Sub Sample()
Dim v As Variant
Dim x As Long
Dim y As Long
Dim dic As Object
Dim dicRow As Object
Dim w() As String
Dim z As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim myName As Variant
Dim rowKey As String
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
Set dicRow = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1") '元シート
With .Range("A1").CurrentRegion
x = .Columns.Count '表の列数
y = .Rows.Count '表の行数
End With
ReDim w(1 To x)
For i = 2 To y
For j = 1 To y Step 3
myName = .Cells(i, j).Value
If Len(myName) > 0 Then '空白はスキップ
If Not dic.exists(myName) Then Set dic(myName) = CreateObject("Scripting.Dictionary")
rowKey = myName & vbTab & j
dicRow(rowKey) = dicRow(rowKey) + 1
n = dicRow(rowKey)
If Not dic(myName).exists(n) Then dic(myName)(n) = w '行スケルトン
z = dic(myName)(n)
z(j) = myName
z(j + 1) = .Cells(i, j + 1).Value
z(j + 2) = .Cells(i, j + 2).Value
dic(myName)(n) = z
End If
Next
Next
End With
i = 2
With Sheets("Sheet2") '転記シート
.Cells.ClearContents
.Range("A1").Resize(, x).Value = Sheets("Sheet1").Range("A1").Resize(, x).Value 'タイトル行コピー
For Each myName In dic
.Range("A" & i).Resize(dic(myName).Count, x).Value = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic(myName).items))
i = i + dic(myName).Count
Next
.Select
End With
Set dic = Nothing
Set dicRow = Nothing
Application.ScreenUpdating = True
MsgBox "転記完了です"
End Sub
|
|
UO3
- 12/3/16(金) 23:09 -
