| |
こんにちは。かみちゃん です。
>>もし、Sheet2への出力がかみちゃんにとって大変な作業であれば、あまりご迷惑をおかけするのも申し訳けありませんので、Sheet1への出力でもかまいません。
>
>改造に少しお時間をいただきたいと思いますが、
>Sheet1への出力ではなく、Sheet2を新規に追加する仕組みではいけませんか？
とりあえず、Sheet1を作業用シートにコピー（シートのコピー）して、作業用シート上で変形処理をして、結果をSheet2へコピーしたのち、必要に応じて罫線処理させるようにしてみました。
これであれば、前回の応用ということになります。
なお、「行列が任意」については、A1を含む空白行、空白列で囲まれたセル範囲になっていますので、A1がその範囲に含まれているという制約だけになります。
Sub Macro1()
Dim MaxRow As Long, MaxColumn As Integer, MaxColumnStart As Integer
Dim RowNo As Long, ColumnNo As Integer
'作業用シートにコピー '★
Sheets("Sheet1").Copy After:=Sheets("Sheet1") '★
'変形前の最終列を取得
'表の途中に空白行、空白列がないことが前提
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 = 3 To MaxColumn
If Cells(RowNo, ColumnNo).Value <> "" Then
If ColumnNo > 3 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, 3)
End If
Else
Exit For
End If
Next
RowNo = RowNo + 1
Loop
'列方向へ挿入した列全体を削除
Range(Columns(4), Columns(MaxColumn)).Delete Shift:=xlToLeft
'作業シートからSheet2へコピーする。コピーしたら作業シートを削除 '★
Range("A1").CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A1") '★
Application.DisplayAlerts = False '★
ActiveSheet.Delete '★
Application.DisplayAlerts = True '★
Sheets("Sheet2").Select '★
Range("A1").Select
'罫線処理が必要であれば、ここから記述
'変形後の表全体の罫線処理（マクロの記録により記述）
Range("A1").CurrentRegion.Select
'〜以下省略 以下のＵＲＬに掲載のコードを参照〜
'http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=17548;id=excel
End Sub
|
|
かみちゃん
- 04/9/4(土) 21:30 -
