| |
▼たろう さん：
ではアップ済みのものをベースに図にしたてあげたものです。
図は、SHeet2に作成します。
Sub Sample2()
Const stFlow As String = "D9"
Const stCell As String = "E14"
Dim lMax As Long
Dim v() As String
Dim joinR() As Range
Dim c As Range
Dim k As Long
Dim oLvl As Long
Dim myR As Range
Dim i As Long
Dim j As Long
Dim flg As Boolean
With Sheets("Sheet1") '元シート
With .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
lMax = WorksheetFunction.Max(.Columns(1))
ReDim v(1 To .Rows.Count, 1 To lMax)
ReDim joinR(1 To lMax)
For Each c In .Columns(1).Cells
If c.Value = 1 Or c.Value <= oLvl Then k = k + 1
v(k, c.Value) = c.Offset(, 1).Value
oLvl = c.Value
Next
End With
End With
With Sheets("Sheet2") '転記シート
With .UsedRange
.Borders.LineStyle = xlNone
.ClearContents
.MergeCells = False
End With
Set myR = .Range(stCell)
Set joinR(1) = .Range(stFlow)
For i = 1 To k
For j = 1 To UBound(v, 2)
If Len(v(i, j)) > 0 Then
myR.Resize(5).Merge
myR.Value = v(i, j)
With myR.Resize(5)
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
flg = False
If j = 1 Then
flg = True
ElseIf Len(v(i, j - 1)) = 0 Then
flg = True
End If
If flg Then
With .Range(joinR(j), myR.Offset(, -1))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
Else
myR.Offset(, -2).Resize(, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
End If
Set joinR(j) = myR.Offset(, -1).Offset(1)
End If
Set myR = myR.Offset(, 3)
Next
Set myR = myR.Offset(6).EntireRow.Cells(.Range(stCell).Column)
Next
.Select
End With
MsgBox "転記完了です"
End Sub
|
|
UO3
- 13/1/17(木) 19:53 -
