| |
▼かみちゃん さん：
こんばんは、さっそく教えて頂いたVBAコード
>>Option Explicit
>>Sub Macro2()
>>
>> Dim MaxColumn As Integer, MaxColumnStart As Integer
> Dim MaxRow As Long, RowNo As Long, ColumnNo As Integer
>>
>>
>> '変形前の最終列を取得
>> '表の途中に空白行、空白列がないことが前提
>> MaxColumn = Range("A1").CurrentRegion.Columns.Count
>> MaxColumnStart = MaxColumn
>> '最終列をカンマ区切りで分割
>> Columns(MaxColumn).Select
>> Selection.TextToColumns Destination:=Cells(1, MaxColumn), DataType:=xlDelimited, _
>> TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
>> Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
>> :=Array(1, 1), TrailingMinusNumbers:=True
>> '変形後の表の大きさを取得
>> MaxColumn = Range("A1").CurrentRegion.Columns.Count
>>
> MaxRow = Range("A1").CurrentRegion.Rows.Count
> '変形処理（列方向へ挿入したセルを行方向へ展開）
> RowNo = 2
> Do Until RowNo > MaxRow
> For ColumnNo = 2 To MaxColumn
> If Cells(RowNo, ColumnNo).Value <> "" Then
> If ColumnNo > 2 Then
> Rows(RowNo).Copy
> Rows(RowNo + 1).Insert Shift:=xlDown
> RowNo = RowNo + 1
> MaxRow = MaxRow + 1
> Application.CutCopyMode = False
> Cells(RowNo - 1, ColumnNo).Copy Destination:=Cells(RowNo, 2)
> End If
> Else
> Exit For
> End If
> Next
> RowNo = RowNo + 1
> Loop
> '列方向へ挿入した列全体を削除
> Range(Columns(3), Columns(MaxColumn)).Delete Shift:=xlToLeft
>>
>> '変形後の表全体の罫線処理（マクロの記録により記述）
>> Range("A1").CurrentRegion.Select
>> Selection.Borders(xlDiagonalDown).LineStyle = xlNone '※
>> Selection.Borders(xlDiagonalUp).LineStyle = xlNone '※
>> With Selection.Borders(xlEdgeLeft)
>> .LineStyle = xlContinuous
>> .Weight = xlThin '※
>> .ColorIndex = xlAutomatic '※
>> End With
>> With Selection.Borders(xlEdgeTop)
>> .LineStyle = xlContinuous
>> .Weight = xlThin '※
>> .ColorIndex = xlAutomatic '※
>> End With
>> With Selection.Borders(xlEdgeBottom)
>> .LineStyle = xlContinuous
>> .Weight = xlThin '※
>> .ColorIndex = xlAutomatic '※
>> End With
>> With Selection.Borders(xlEdgeRight)
>> .LineStyle = xlContinuous
>> .Weight = xlThin '※
>> .ColorIndex = xlAutomatic '※
>> End With
>> With Selection.Borders(xlInsideVertical)
>> .LineStyle = xlContinuous
>> .Weight = xlThin '※
>> .ColorIndex = xlAutomatic '※
>> End With
>> With Selection.Borders(xlInsideHorizontal)
>> .LineStyle = xlContinuous
>> .Weight = xlThin '※
>> .ColorIndex = xlAutomatic '※
>> End With
>> '拡張したタイトル行の修正
>> Range(Cells(1, MaxColumnStart), Cells(1, MaxColumn)).Select
>>' Range("C1:E1").Select
>> Selection.Borders(xlDiagonalDown).LineStyle = xlNone '※
>> Selection.Borders(xlDiagonalUp).LineStyle = xlNone '※
>> With Selection.Borders(xlEdgeLeft) '※
>> .LineStyle = xlContinuous '※
>> .Weight = xlThin '※
>> .ColorIndex = xlAutomatic '※
>> End With '※
>> With Selection.Borders(xlEdgeTop) '※
>> .LineStyle = xlContinuous '※
>> .Weight = xlThin '※
>> .ColorIndex = xlAutomatic '※
>> End With '※
>> With Selection.Borders(xlEdgeBottom) '※
>> .LineStyle = xlContinuous '※
>> .Weight = xlThin '※
>> .ColorIndex = xlAutomatic '※
>> End With '※
>> With Selection.Borders(xlEdgeRight) '※
>> .LineStyle = xlContinuous '※
>> .Weight = xlThin '※
>> .ColorIndex = xlAutomatic '※
>> End With '※
>> Selection.Borders(xlInsideVertical).LineStyle = xlNone
>> '拡張したタイトルをセル結合する
>> Selection.MergeCells = True
>> Range("A1").Select
>>
>>End Sub
で、前掲例題
┌─┬─┬───┐
│A │B │C │
├─┼─┼───┤
│1 │あ│a │
├─┼─┼───┤
│2 │い│ │
├─┼─┼───┤
│3 │う│b,c │
├─┼─┼───┤
│4 │え│d │
├─┼─┼───┤
│5 │お│e,f,g │
└─┴─┴───┘
を処理してみたのですが
ワークシートSheet1に変換された表は
┌─┬─┬─────────┐
│A │B │ │
├─┼─┼─────────┘
│1 │あ│
├─┼─┤
│1 │a │
├─┼─┤
│2 │い│
├─┼─┤
│3 │う│
├─┼─┤
│3 │b │
├─┼─┤
│3 │c │
├─┼─┤
│4 │え│
├─┼─┤
│4 │d │
├─┼─┤
│5 │お│
├─┼─┤
│5 │e │
├─┼─┤
│5 │f │
├─┼─┤
│5 │g │
└─┴─┘
のようになってしまい、私が望んでいた処理結果
┌─┬─┬───┐
│A │B │C │
├─┼─┼───┤
│1 │あ│a │
├─┼─┼───┤
│2 │い│ │
├─┼─┼───┤
│3 │う│b │
├─┼─┼───┤
│3 │う│c │
├─┼─┼───┤
│4 │え│d │
├─┼─┼───┤
│5 │お│e │
├─┼─┼───┤
│5 │お│f │
├─┼─┼───┤
│5 │お│g │
└─┴─┴───┘
のようにはなりませんでした。また変換処理表はワークシートSheet2に出力したいんです。たびたびですみませんが、いま一度この例題でVBAコードをチェックして頂けませんか？
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 04/9/4(土) 0:13 -
