エクセルの折り返し

質問

Excel2007です。 VBAでセルを結合させて、文字の記入欄を作っていたのですが、
文字が長くなる可能性があるので、
VBA側で結合処理後に折り返しさせる処理を追加して、
折り返しができるようにしたのですが、
いざ、文字を記入してEnterで次のセルへ移動したら、
折り返しが勝手に解除してしまい、1行で表示してしまいます。
何度やっても解除してしまいます。
原因は何でしょうか？
また、対処法はどうしたらよいでしょうか？

回答No.3

usami33

もう一つの方法
折り返しの文字数を定義します
http://www.d3.dion.ne.jp/~jkondou/excelvba/K5.htm

回答No.2

usami33

文字列を生成しているのではなくプロパティだけでやっていたのですね

ここで説明されているAutoFitを追加してみてください。
http://www.big.or.jp/~seto/vbaref/vbaref5.htm

回答No.1

usami33

エクセルの改行コードは通常と違うのですが、ここも考慮されてますか？
http://officetanaka.net/excel/vba/tips/tips89.htm

補足

考慮してません・・・ちなみにこれがコードです
'集計元が格納されているフォルダを選択してもらう
Set Shell = CreateObject("Shell.Application") _
.BrowseForFolder(0, "フォルダを選択してください。", 0, ThisWorkbook.Path)
If Shell Is Nothing Then
FolderPath = ""
IsFolderPath = False
Else
FolderPath = Shell.Items.Item.Path
ChDir (FolderPath)
IsFolderPath = True
End If
If (IsFolderPath) Then

'ペースト箇所の行数加算用の変数
Dim row As Integer
row = 20

Dim ShareKey As String '検索する文字
Dim NameKey As String '検索する文字
Dim ShareRange As Range '検索されたセル
Dim NameRange As Range '検索されたセル
Dim NameSheet As String 'シート名を取得する
Dim CountX As Integer '列座標
Dim CountY As Integer '行座標

ShareKey = "【満足度】" '検索したい項目名を設定
NameKey = "氏　名" '検索したい項目名を設定

'選択フォルダ内から、順次内容をコピー&ペーストしていく
FileName = Dir("*.xls")

If FileName = "" Then
MsgBox "抽出対象ファイルがありません。"
End If

Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then
Workbooks.Open (FileName)

'対象項目の検索
Set ShareRange = Cells.Find(What:=ShareKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
Set NameRange = Cells.Find(What:=NameKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)

NameSheet = ActiveSheet.Name 'シート名を取得
CountX = 1 '初期値設定
CountY = 0 '初期値設定

If (ShareRange Is Nothing) Then
MsgBox "抽出項目が見つかりません"
Workbooks(FileName).Close SaveChanges:=False
Else
'抽出用ファイルへコピー&ペースト
Cells(NameRange.row, NameRange.Column + 4).Copy
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("B" & row).PasteSpecial Paste:=xlPasteValues
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("B" & row).ClearComments

'満足度のコピー&ペースト
Do While CountY < 5
Do While CountX < 4
Select Case CountX
Case 1
Workbooks(FileName).Worksheets(NameSheet).Range("A" & ShareRange.row + CountY + 1).Copy
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("B" & row + CountY + 1).PasteSpecial Paste:=xlPasteValues
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("B" & row + CountY + 1).ClearComments
Case 2
Workbooks(FileName).Worksheets(NameSheet).Range("Q" & ShareRange.row + CountY + 1).Copy
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("C" & row + CountY + 1).PasteSpecial Paste:=xlPasteValues
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("C" & row + CountY + 1).ClearComments
Case 3
Workbooks(FileName).Worksheets(NameSheet).Range("U" & ShareRange.row + CountY + 1).Copy
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("E" & row + CountY + 1).PasteSpecial Paste:=xlPasteValues
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("E" & row + CountY + 1).ClearComments
End Select
CountX = CountX + 1
Loop
CountY = CountY + 1
CountX = 1
Loop
Workbooks(FileName).Close SaveChanges:=False
row = row + CountY + 3
End If
End If
FileName = Dir()
Loop
'列の幅の自動調整
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("B25").Columns.AutoFit
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("E21").Columns.AutoFit
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("E22:E100").WrapText = True

'コメント欄生成
Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("B" & row).Value = "【コメント記入欄】"

'コメント欄を結合し、文字列配置を上揃えにして、折り返しさせる
With Workbooks("抽出用マクロ.xlsm").Worksheets("マクロ").Range("B" & row + 1 & ":" & "E" & row + 7)
.MergeCells = True
.Borders.LineStyle = xlContinuous
.VerticalAlignment = xlTop
.NumberFormatLocal = "@" ' 表示形式を文字列にする
.WrapText = True ' 文字列を折り返しにする
End With
MsgBox "完了しました"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If