エクセル2007で、マクロで、結合セルに入れた文字列の折り返し回数を取

エクセル2007で、マクロで、結合セルに入れた文字列の折り返し回数を取得する方法はありますか。改行回数（chr(10))ではなく折り返し回数です。

No.4 回答者： Wendy02 回答日時： 2010/10/22 18:33

なぜか、私の#2のコードで、一部文字が落ちているようです。

全体を見なおしてみました。

'//
Sub CountLineInCell()
　Dim sh1 As Worksheet, sh2 As Worksheet
　Dim w As Double, c As Variant
　Dim tmpCell As Range
　Dim msg As Variant
　Dim ar As Variant
　Dim cnt As Long, fntNam As String, fntSize As Double, iFnt As Integer
　Set sh1 = ActiveSheet
　With sh1.Range("A1").MergeArea 'Range("A1")は、ActiveCell でも可能
　If .Cells(1, 1).Value = "" Then Set sh1 = Nothing: Exit Sub
　　 fntNam = .Cells(1, 1).Font.Name
　　 fntSize = .Cells(1, 1).Font.Size
　　For Each c In .Cells
　　　w = w + c.ColumnWidth
　　　'空白行のために必要ですが、今回は無視します。
　　　'cnt = cnt + Len(c.Value) - Len(Replace(c.Value, vbLf, ""))
　　Next
　　　ar = Split(.Cells(1, 1), vbLf)
　　Set sh2 = Worksheets.Add(After:=Worksheets(Sheets.Count))
　End With
　With sh2
　　 If fntSize < 11 Then
　　　 iFnt = 3
　　 ElseIf fntSize >= 11 Then
　　　 iFnt = 0
　　 End If
　　.Cells(1, 1).ColumnWidth = Int(w * 10 + 2 + iFnt) / 10 '係数
　　Application.DisplayAlerts = False
　　For i = 0 To UBound(ar)
　　　If i = 0 Then
　　　　With .Cells(1, 1)
　　　　　.Resize(100).Font.Name = fntNam
　　　　　.Resize(100).Font.Size = fntSize
　　　　　.Value = ar(i)
　　　　　.WrapText = True
　　　　　.EntireRow.AutoFit
　　　　　.Justify
　　　　End With
　　　Else
　　　　With .Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　　　If ar(i) <> "" Then
　　　　　.Value = ar(i)
　　　　　.WrapText = True
　　　　　.EntireRow.AutoFit
　　　　　.Justify
　　　　End If
　　　　End With
　　　End If
　　Next
　　msg = .Cells(Rows.Count, 1).End(xlUp).Row
　End With
　sh2.Delete
　Application.DisplayAlerts = True
　sh1.Activate
　MsgBox msg
　Set sh1 = Nothing: Set tmpCell = Nothing: Set sh2 = Nothing
End Sub

ところで、こちらの#2の文字のズレについては気が付きませんでしたが、この方法の延長で間違いないと思っています。この件は、かなり昔に一度、同じような問題で手を付けています。その時は、結論が出ていませんでした。

これは、実際のテストを行って、実測に合わせて係数で解決するように考えています。つまり、うまく行かなかったら係数で個人が処理してもらうしかありません。

Excel側で何かの丸めが介在してしまうようです。しかし、セルの高さを標準セルの高さで割る方法は、いくらAutoFit しても、フォントの違いよって、予想の付かないマージンが入ることは、Excel2000時代から知っていましたので、そういう方法を取りませんでした。

フォントは、11 point,[MS Pゴシック]/[MSゴシック]8point から16point まで、までで、20行以内について検査しています。

No.3 回答者： mitarashi 回答日時： 2010/10/11 22:06

#1です。

Wendy02様、日頃ご回答を参考にさせていただいておりますが、今回は勘違いされていると存じます。
AutoFitするのは、作業用の単独セルのみで、mergeしたセルは操作いたしません。
試しに試験用のコードを書いてみました。一旦丸ごとコピーする事で、書式設定をそのまま引き継ごうという魂胆です。手動で試してみましたが、行数が多くなると、実際とズレが大きくなってきて、「文字の割付」の方が実際の値に近い様ですが、そちらも改行位置は若干ずれます。折り返し行数を取得して、結合セルの高さを変更する際は、余裕をみて設定する必要がありそうです。なお、当方xl2000で試しています。
Sub test()
Debug.Print funcTest
End Sub

Function funcTest() As Long
Dim tmpSh As Worksheet
Dim myRange As Range, tempRange As Range
Dim mergeWidth As Double, mergeHeight As Double
Dim i As Long
Dim fittedHeight As Double, singleHeight As Double

Set tmpSh = Sheets(2)
tmpSh.cells.clear
Set myRange = ActiveCell
Set tempRange = tmpSh.Cells(1)
For i = 1 To myRange.MergeArea.Columns.Count
mergeWidth = mergeWidth + myRange.MergeArea.Columns(i).ColumnWidth
Next i
For i = 1 To myRange.MergeArea.Rows.Count
mergeHeight = mergeHeight + myRange.MergeArea.Rows(i).RowHeight
Next i
myRange.Copy tempRange
tempRange.MergeCells = False
With tempRange
.EntireColumn.ColumnWidth = mergeWidth
.EntireRow.AutoFit
fittedHeight = .EntireRow.RowHeight
.WrapText = False
.EntireRow.AutoFit
singleHeight = .EntireRow.RowHeight
End With
funcTest = Int(fittedHeight / singleHeight) + 1
End Function

No.2 回答者： Wendy02 回答日時： 2010/10/10 22:48

#1の方の引用先の内容は、せっかくで申し訳ないけれども、解決はしていないと思います。

結合セルにAutoFit を使えば、折り返しが崩れてしまいます。Justifyを用いればよいのではないかと思います。

手動で説明すると、
例えば、A1 にあるとしたら、どこかの新しいシートのひとつの結合していないセルの幅を、元のA1セルの幅に合わせ、文字列のみをコピーして、編集--フィル--文字の割り付け
で行を数えればよいということです。

あまり実用的ではないと思いますが、それをマクロにすると以下のようになるように思いました。ただ、基本的には、結合セルは、VBAでは、ネックになります。挙動がまったく変わってしまうことがあるからです。

'//
Sub CountLineInCell()
　Dim sh1 As Worksheet, sh2 As Worksheet
　Dim w As Double, c As Variant
　Dim tmpCell As Range
　Dim msg As Variant
　Set sh1 = ActiveSheet
　With sh1.Range("A1").MergeArea 'Range("A1")は、ActiveCell でも可能
　　If .Cells(1, 1).Value = "" Then Set sh1 = Nothing: Exit Sub
　　For Each c In .Cells
　　　w = w + .ColumnWidth
　　Next
　　Set sh2 = Worksheets.Add(After:=Worksheets(Sheets.Count))
　　sh2.Cells(1, 1).Value = .Value
　End With
　Application.DisplayAlerts = False
　With sh2.Cells(1, 1)
　　.ColumnWidth = w
　　.WrapText = True
　　.EntireRow.AutoFit
　　.Justify
　　msg = .Cells(Rows.Count, 1).End(xlUp).Row
　End With
　sh2.Delete
　Application.DisplayAlerts = True
　sh1.Activate
　MsgBox msg
　Set sh1 = Nothing: Set tmpCell = Nothing: Set sh2 = Nothing
End Sub

No.1 回答者： mitarashi 回答日時： 2010/10/10 20:12

http://okwave.jp/qa/q2511169.html
の#2がご参考になると存じます。
フォント等の環境を合致させた作業用の単独セルに文字列をコピーし、AutoFitを実行して、結果の行の高さを求める方法です。

この回答へのお礼

なるほど、発想がすばらしですね。折り返し回数にだけにこだわってましたが、確かにそういう手段が考えられますね。ありがとうございました。

お礼日時：2010/10/10 21:04