| |
▼かみちゃん さん：
こんばんは、しんです。
かみちゃんご呈示のVBAコード
>
>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
で例題の処理を行った結果、３列の場合は正常に変換できることが確認できました。かみちゃんとKeinさんには親身になってお世話を頂き、どうもほんとうにありがとうございました。今後ともよろしくご教示お願いします。
|
|
しん
- 04/9/5(日) 0:04 -
