Excelで長い文章を入力すると、印刷するとき行が切れてしまうことがあります。あまりに頻発して頭に来たのでエクセル・マクロを作ってみました。


Public Sub 行高さを1割増しにする()
Dim 現在行 As Range
For Each 現在行 In ActiveCell.CurrentRegion.Rows
現在行.Select
Selection.RowHeight = Selection.RowHeight * 1.1
Next
DoEvents
End Sub

すべての行を自動的に1割り増しにするマクロです。

が、これでもうまくいかないことがあるのです。どなたか、改良型を作ってみてはいただけないでしょうか。

関連質問:
http://q.hatena.ne.jp/1146643798
http://q.hatena.ne.jp/1125885317

回答の条件
  • 1人5回まで
  • 登録:2006/07/20 21:47:08
  • 終了:2006/07/21 20:08:05

回答(4件)

id:gong1971 No.1

gong1971回答回数443ベストアンサー獲得回数682006/07/20 22:26:35

ポイント20pt

収まらない場合は、1行分の余裕が必要なので1割増だと、

10行以上ある場合でないと効果が出ないかと思われます。


という訳で、標準フォントのフォントサイズが11という

私の環境では + 13.5 とする事で1行分確保可能です。

Selection.RowHeight = Selection.RowHeight * 1.1
↓
Selection.RowHeight = Selection.RowHeight + 13.5

また、プロポーショナルフォントの際に、当該の現象が

起きやすいように思います。(※「MS Pゴシック」「MS P明朝」

など P が付くフォントがプロポーショナルフォントになります。)

P の付かない当幅フォント(※「MS ゴシック」「MS 明朝」など)を

ご使用されてはいかがでしょうか?

id:over40

なるほど、必ず1行足せばいいのか。

ありがとうございます。

2006/07/20 23:03:10
id:llusall No.2

llusall回答回数505ベストアンサー獲得回数612006/07/20 22:48:13

行の高さを自動調整するよう改修してみました。


Public Sub 行高さを1割増しにする()

    Dim 現在行 As Range

    For Each 現在行 In ActiveCell.CurrentRegion.Rows

        現在行.Select

'       Selection.RowHeight = Selection.RowHeight * 1.1

        Selection.EntireRow.AutoFit '高さの自動調整

    Next

    DoEvents

End Sub

id:over40

えーと、元に戻っちゃうんですけど。

AutoFitの不具合を微調整しようというマクロですので。

自分で改造していたら分けわかんなくなってきました。うまくいったりいかなかったりです。

Sub 行高さの自動調整()

Dim セル内の文字数 As Double

Dim 一行高さ As Double

Dim 行数 As Double

Dim セルの幅 As Double

Dim 現在行高さ As Double

Dim 現在行番号 As Double

Const Font12Ht = 14.25

Const Font11Ht = 13.5

Const Font10Ht = 12

Const font9Ht = 11.25

'幅の調整

Const 幅調整 As Double = 1.5

'縦の調整

Const 高さ調整 As Double = 0 'フォント高×1.0~1.5

'

Dim 現在セル As Range

For Each 現在セル In ActiveCell.CurrentRegion.Cells

If 現在行番号 < Selection.Row Then

現在行番号 = Selection.Row

現在行高さ = 0

End If

現在セル.Select

セルの幅 = Int(Selection.ColumnWidth + 幅調整)

セル内の文字数 = LenB(StrConv(Selection.Value, vbFromUnicode))

行数 = セル内の文字数 / セルの幅

If 行数 - Int(行数) > 0 Then

行数 = Int(行数 + 1)

End If

Select Case Selection.Font.Size

Case 12

一行高さ = Font12Ht

Case 11

一行高さ = Font11Ht

Case 10

一行高さ = Font10Ht

Case 9

一行高さ = font9Ht

End Select

If 現在行高さ < (一行高さ * 行数 + 高さ調整) Then

現在行高さ = 一行高さ * 行数 + 高さ調整

Selection.RowHeight = 現在行高さ

End If

Next

2006/07/21 02:51:08
id:freemann No.3

freemann回答回数315ベストアンサー獲得回数502006/07/21 10:51:19

ポイント20pt

簡単なテストをしただけですけど、こんなのもあるかなと・・・

Dim a As Range

Dim i As Long

Dim colEnd As Long

Dim colStart As Long

Dim currentRow As Long

Dim rowStart As Long

Dim rowEnd As Long

Dim cellWidth As Double

Dim cellHeight As Double

Dim valWidth As Double

Dim valHeight As Double

Dim maxHeight As Double

Dim cellLines As Integer

Dim needLines As Integer

Dim tmpDouble As Double

Dim charNum As Integer

'フォントの高さ

Const Font12Ht = 14.25

Const Font11Ht = 13.5

Const Font10Ht = 12

Const font9Ht = 11.25

'フォントの幅

Const Font12Wd = 2 'ダミー

Const Font11Wd = 2 'ダミー

Const Font10Wd = 2 'ダミー

Const Font9Wd = 2 'ダミー

'幅の調整

Const 幅調整 As Double = 1.5

'縦の調整

Const 高さ調整 As Double = 0 'フォント高×1.0~1.5

colStart = 0

colEnd = 0

rowStart = 0

i = 0

'選択範囲の左上と右下の行列の番号取得ループ

For Each a In Selection

If i = 0 Then

colStart = a.Column

rowStart = a.Row

End If

i = a.Column

rowEnd = a.Row

colEnd = a.Column

Next a

currentRow = rowStart

maxHeight = 0#

For Each a In Selection

'行が次に移ったか判定

If currentRow <> a.Row Then

'初期化

currentRow = a.Row

maxHeight = 0#

End If

With a

charNum = LenB(StrConv(.Value, vbFromUnicode))

'フォントサイズによって一文字の大きさを取得

Select Case .Font.Size

Case 12

valWidth = charNum * Font12Wd / 2

valHeight = Font12Ht

Case 11

valWidth = charNum * Font11Wd / 2

valHeight = Font11Ht

Case 10

valWidth = charNum * Font10Wd / 2

valHeight = Font10Ht

Case 9

valWidth = charNum * Font9Wd / 2

valHeight = font9Ht

End Select

'必要とされる行数

needLines = Int(valWidth / .ColumnWidth) + 1

'現在の行数

cellHeight = Int(valHeight / .rowHeight) + 1

If needLines > cellHeight Then

'各行で最も必要とされる高さを取得

If maxHeight < (needLines * valHeight) Then

maxHeight = needLines * valHeight

End If

End If

End With

'行の高さを変更

If colEnd = a.Column Then

a.Rows(1).rowHeight = maxHeight

End If

Next a

id:over40

おお!なんか動作が速いです。

どうしても、プラス1行するほかないのでしょうか。

2006/07/21 12:12:45
id:freemann No.4

freemann回答回数315ベストアンサー獲得回数502006/07/21 15:04:06

ポイント50pt

先ほどの回答にバグがあったので新しいものを載せます。

Dim a As Range

Dim i As Long

Dim colEnd As Long

Dim colStart As Long

Dim currentRow As Long

Dim rowStart As Long

Dim rowEnd As Long

Dim cellWidth As Double

Dim cellHeight As Double

Dim valWidth As Double

Dim valHeight As Double

Dim maxHeight As Double

Dim cellLines As Integer

Dim needLines As Integer

Dim tmpDouble As Double

Dim charNum As Integer

'フォントの高さ

Const Font12Ht = 14.25

Const Font11Ht = 13.5

Const Font10Ht = 12

Const font9Ht = 11.25

'フォントの幅

Const Font12Wd = 2 'ダミー

Const Font11Wd = 2 'ダミー

Const Font10Wd = 2 'ダミー

Const Font9Wd = 2 'ダミー

'幅の調整

Const 幅調整 As Double = 1.5

'縦の調整

Const 高さ調整 As Double = 0 'フォント高×1.0~1.5

colStart = 0

colEnd = 0

rowStart = 0

i = 0

'選択範囲の左上と右下の行列の番号取得ループ

For Each a In Selection

If i = 0 Then

colStart = a.Column

rowStart = a.Row

End If

i = a.Column

rowEnd = a.Row

colEnd = a.Column

Next a

currentRow = rowStart

maxHeight = 0#

For Each a In Selection

'行が次に移ったか判定

If currentRow <> a.Row Then

'初期化

currentRow = a.Row

maxHeight = 0#

End If

With a

charNum = LenB(StrConv(.Value, vbFromUnicode))

'フォントサイズによって一文字の大きさを取得

Select Case .Font.Size

Case 12

valWidth = charNum * Font12Wd / 2

valHeight = Font12Ht

Case 11

valWidth = charNum * Font11Wd / 2

valHeight = Font11Ht

Case 10

valWidth = charNum * Font10Wd / 2

valHeight = Font10Ht

Case 9

valWidth = charNum * Font9Wd / 2

valHeight = font9Ht

End Select

'必要とされる行数

tmpDouble = valWidth / .ColumnWidth

needLines = Int(tmpDouble)

If tmpDouble < 1 Then

needLines = needLines + 1

ElseIf (tmpDouble) Mod 1 <> 0 Then

needLines = needLines + 1

End If

'現在の行数

tmpDouble = .rowHeight / valHeight

cellHeight = Int(tmpDouble)

If tmpDouble < 1 Then

cellHeight = cellHeight + 1

ElseIf (tmpDouble Mod 1) <> 0 Then

cellHeight = cellHeight + 1

End If

If needLines >= cellHeight Then

'各行で最も必要とされる高さを取得

If maxHeight < (needLines * valHeight) Then

maxHeight = needLines * valHeight

End If

End If

End With

'行の高さを変更

If colEnd = a.Column Then

a.Rows(1).rowHeight = maxHeight

End If

Next a

それと補足説明を(ちょっと説明が足りなかったかも)

このプログラムでは、例えば現在の行の高さが1行分しかなく、セルにおさめるには3行必要だった場合は3行の高さをとるようになっています。(ただ単純に1行プラスしてるわけではないです)

id:over40

ありがとうございます。

ばっちぐーです。

アドインにしてみました。

http://www.o40.org/blog/archives/2006/07/excel.php

2006/07/21 19:47:44

コメントはまだありません

この質問への反応(ブックマークコメント)

トラックバック

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません