Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2016)
統合セルの高さ一括自動調整について
投稿日時: 18/01/30 15:57:40
投稿者: papato

エクセルには、セルの高さを自動調整すつ機能がありますが、結合されているセルに対しては、作動しません。
 
そこで、自分なりに既存のVBAコードを検索してたところ、こちら(http://blog.contextures.com/archives/2015/12/03/autofit-merged-cells-row-height-update-20151203/)のサイトに記載のコードが使えるのではないか、との結論に至りました。
 
↓該当コード
Option Explicit
 
Sub MergedAreaRowAutofit()
Dim j As Long
Dim n As Long
Dim i As Long
Dim MW As Double 'merge width
Dim RH As Double 'row height
Dim MaxRH As Double
Dim rngMArea As Range
Dim rng As Range
  
Const SpareCol As Long = 26
Set rng = Range("C10:O" & _
  Range("C" & Rows.Count).End(xlUp).Row)
 
With rng
  For j = 1 To .Rows.Count
     'if the row is not hidden
    If Not .Parent.Rows(.Cells(j, 1).Row) _
      .Hidden Then
       'if the cells have data
      If Application.WorksheetFunction _
        .CountA(.Rows(j)) Then
        MaxRH = 0
        For n = .Columns.Count To 1 Step -1
          If Len(.Cells(j, n).Value) Then
             'mergecells
            If .Cells(j, n).MergeCells Then
              Set rngMArea = _
                .Cells(j, n).MergeArea
              With rngMArea
                MW = 0
                If .WrapText Then
                   'get the total width
                  For i = 1 To .Cells.Count
                    MW = MW + _
                      .Columns(i).ColumnWidth
                  Next
                  MW = MW + .Cells.Count * 0.66
                   'use the spare column
                   'and put the value,
                   'make autofit,
                   'get the row height
                  With .Parent.Cells(.Row, SpareCol)
                    .Value = rngMArea.Value
                    .ColumnWidth = MW
                    .WrapText = True
                    .EntireRow.AutoFit
                    RH = .RowHeight
                    MaxRH = Application.Max(RH, MaxRH)
                    .Value = vbNullString
                    .WrapText = False
                    .ColumnWidth = 8.43
                  End With
                  .RowHeight = MaxRH
                End If
              End With
            ElseIf .Cells(j, n).WrapText Then
              RH = .Cells(j, n).RowHeight
              .Cells(j, n).EntireRow.AutoFit
              If .Cells(j, n).RowHeight < RH Then _
                .Cells(j, n).RowHeight = RH
            End If
          End If
        Next
      End If
    End If
  Next
  .Parent.Parent.Worksheets(.Parent.Name).UsedRange
End With
End Sub
↑以上
 
早速以下条件のシートに対し、適用しさせようと、Constあたりの数字を適当にいじってみたらマグレで動作したのですが、どの数字をいじったかわからなくなってしまいました。。。。
 
どなたか、どこの数値を変えれば、以下条件下で作動するかご存じないでしょうか。または、もっとシンプルなコードがありましたらご教示いただきたく。VBA初心者で本当に恐縮なのですが、どうぞ宜しくお願い致します。
 
・セルB3:J3からセルB1306:J1306まで、1306行にわたり1行ずつ結合させています。
・各結合セルには文字列があり、折り返しさせています。
・1行ずつに対し、文字列が全体表示されるように、高さを自動調整させたいです。
 
以上、わかりづらい箇所ありましたら、補足しますのでお知らせください。皆様のお返事お待ちしております。

回答
投稿日時: 18/01/30 17:45:28
投稿者: WinArrow
投稿者のウェブサイトに移動

ステップ実行で、再確認してみましょう。

回答
投稿日時: 18/01/30 18:27:19
投稿者: もこな2

私も以前似たようなこと考えて、取り組んだものの難しくて途中でぶん投げた記憶が。。。
 
とりあえずアイデアとして提供します。
(1)LENB関数で結合セルに入力されてる文字バイト数を数える。
(2)結合セルの列幅を調べて小数点以下切り捨てつつ変数「x」に格納する。
(3)(1)をxで除して必要行数「y」を算出する
(4)結合セルに入力されている改行コードの数を調べて「y」に加算する。
(5)「y」に予備行として1〜2行ほど追加する
(6)13.5(←1行分の高さに変えて下さい) に 「y」を乗じて、必要な高さを算出する。
(7)算出した高さに行の高さを変更する。
 
私の場合は、行方向にも結合してたのでもっとごちゃごちゃやってましたけど、これでまぁまぁ成功しました。
本当はぴったりフィットさせたかったんですけど、改行コードがあることがある、2バイト文字で入力するといったハードルがあって、結局(5)のように予備行をちょこっといれて対応するで何とかしのぎました。
 
参考になれば幸いです。

回答
投稿日時: 18/01/30 18:36:56
投稿者: WinArrow
投稿者のウェブサイトに移動

いろいろ計算しても、ずばりの値を求めるのは、難しいです。
 
作業シートを利用する方法があります。
とにかく、1つのセルに格納すれば、AUtoFitが使えるので、その値を
元シートに適用するというものです。
結合セルのみを対象にするわけですので、結合セル個数で案分します。

投稿日時: 18/01/30 19:59:01
投稿者: papato

もこな2さん
 
 
ご丁寧にわかりやすく、ありがとうございます。
私の文中のコードですと(どういう仕組みがわからないんですが)何行分でもきれいにフィットしました。
 
同じ悩みを抱えていらっしゃると聞いて、がぜん探究し甲斐のあるイシューなんだな、と感じました。引き続き何か発見等ありましたらご共有いただけると幸いです。
 
 
Papato
 
 

もこな2 さんの引用:
私も以前似たようなこと考えて、取り組んだものの難しくて途中でぶん投げた記憶が。。。
 
とりあえずアイデアとして提供します。
(1)LENB関数で結合セルに入力されてる文字バイト数を数える。
(2)結合セルの列幅を調べて小数点以下切り捨てつつ変数「x」に格納する。
(3)(1)をxで除して必要行数「y」を算出する
(4)結合セルに入力されている改行コードの数を調べて「y」に加算する。
(5)「y」に予備行として1〜2行ほど追加する
(6)13.5(←1行分の高さに変えて下さい) に 「y」を乗じて、必要な高さを算出する。
(7)算出した高さに行の高さを変更する。
 
私の場合は、行方向にも結合してたのでもっとごちゃごちゃやってましたけど、これでまぁまぁ成功しました。
本当はぴったりフィットさせたかったんですけど、改行コードがあることがある、2バイト文字で入力するといったハードルがあって、結局(5)のように予備行をちょこっといれて対応するで何とかしのぎました。
 
参考になれば幸いです。

回答
投稿日時: 18/01/31 19:11:58
投稿者: simple

引用:
どなたか、どこの数値を変えれば、以下条件下で作動するかご存じないでしょうか。または、もっとシンプルなコードがありましたらご教示いただきたく。VBA初心者で本当に恐縮なのですが、どうぞ宜しくお願い致します。

おっしゃることがよくわかりません。
最初のところで、
・作業列としてZ列を使用する
・対象範囲の指定
をしている、とわかるだけでいいじゃないですか?
希望する動作なんでしょ?
要するにそのコードを解読して説明してくれ、ということですか?
それはあなたが必要に応じてやってくださいよ。
コメントだってついているわけですよね。

回答
投稿日時: 18/02/01 14:00:26
投稿者: mattuwan44

セルを結合しないでオートフィットで行高が上手く調整できるなら、
セルを結合しない方向で考えた方がいいです。
むしろセルを結合する意味が知りたいです。
代案があるかも知れないし、ないかもしれませんが、
セル内の文字列が改行して何行になるかを正確に把握することは、
すごい難しいです。
オートフィットも完璧かどうかよくわからないし。。。。
エクセルで文字切れを完全になくすのは、無理です。
(マイクロソフトもそこは割り切って諦めているのですから。。。)

回答
投稿日時: 18/02/01 14:44:40
投稿者: mattuwan44

Option Explicit
 
Sub MergedAreaRowAutofit()
    Dim j As Long
    Dim n As Long
    Dim i As Long
    Dim MW As Double 'merge width
    Dim RH As Double 'row height
    Dim MaxRH As Double
    Dim rngMArea As Range
    Dim rng As Range
 
    Const SpareCol As Long = 26 'スペア? 作業列のことか?
     
    '探索対象セル範囲
    Set rng = Range("C10:O" & Range("C" & Rows.Count).End(xlUp).Row)
 
    With rng
        For j = 1 To .Rows.Count
            'もし行が非表示でなかったら
            If Not .Parent.Rows(.Cells(j, 1).Row).Hidden Then
                'もし、セルにデータがあれば
                If Application.WorksheetFunction.CountA(.Rows(j)) Then
                    MaxRH = 0
                    '列を右から順に見て行く
                    For n = .Columns.Count To 1 Step -1
                        'もし、セルの値の文字すうが0より長かったら
                        If Len(.Cells(j, n).Value) Then
                            'もし対象セルが結合セルだったら
                            If .Cells(j, n).MergeCells Then
                                Set rngMArea = .Cells(j, n).MergeArea
                                With rngMArea
                                    MW = 0
                                    'もし対象セルが折り返し有の設定になっていたら
                                    If .WrapText Then
                                        '対象結合セルの幅を取得
                                        For i = 1 To .Cells.Count
                                            MW = MW + .Columns(i).ColumnWidth
                                        Next
                                        MW = MW + .Cells.Count * 0.66 '1列当り0.66の余裕を追加?(罫線分?)
                                        '作業列を使って値を書出し、オートフィットを使って行高を取得
                                        With .Parent.Cells(.Row, SpareCol)
                                            .Value = rngMArea.Value '値を転記
                                            .ColumnWidth = MW '列幅を設定
                                            .WrapText = True '折り返し有
                                            .EntireRow.AutoFit '行全体をオートフィット
                                            RH = .RowHeight '行高を取得
                                            MaxRH = Application.Max(RH, MaxRH) '前の列で取得した列高と比べて大きい方を取得
                                            .Value = vbNullString 'Null値を代入(作業列を空白に戻している?)
                                            .WrapText = False '折り返しなしに戻す
                                            .ColumnWidth = 8.43 '列幅を初期値に戻す
                                        End With
                                        .RowHeight = MaxRH '行高を取得した値に反映
                                    End If
                                End With
                            'もし、単一セルで折り返し有なら
                            ElseIf .Cells(j, n).WrapText Then
                                RH = .Cells(j, n).RowHeight '今の行高を記憶
                                .Cells(j, n).EntireRow.AutoFit 'オートフィットしてみる
                                '記憶した行高とオートフィットしてみた行高と大きい方を採用
                                If .Cells(j, n).RowHeight < RH Then .Cells(j, n).RowHeight = RH
                            End If
                        End If
                    Next
                End If
            End If
        Next
        '対象シートの使用範囲のリフレッシュ
        .Parent.Parent.Worksheets(.Parent.Name).UsedRange
    End With
End Sub
 
他人がどうやっているか一応読んでコメント入れてみた。。。
 

引用:

投稿日時: 18/01/30 18:36:56 投稿者: WinArrow
いろいろ計算しても、ずばりの値を求めるのは、難しいです。
  
作業シートを利用する方法があります。
とにかく、1つのセルに格納すれば、AUtoFitが使えるので、その値を
元シートに適用するというものです。

同じ考えのようですね。
 
>または、もっとシンプルなコードがありましたら
頭の体操に、いまから何か考えてみましょう^^
 

回答
投稿日時: 18/02/01 15:33:57
投稿者: mattuwan44

Sub test()
    Dim rngTarget As Range
    Dim rngSpare As Range
    Dim r As Range
 
    Set rngTarget = Range("B2:B6") '対象セル範囲
    Set rngSpare = rngTarget.Offset(, 30) '作業用セル範囲(30列分右で作業)
 
    With rngSpare
        .Value = rngTarget.Value '値の転記
        .WrapText = True '折り返し有
        .ColumnWidth = GetMergeWidth(rngTarget(1).MergeArea) '列幅の設定
        .EntireRow.AutoFit 'オートフィット
        For Each r In .Cells
            r.RowHeight = r.RowHeight '行高の設定(オートフィットの解除)
        Next
        .EntireColumn.Delete '作業列の削除
    End With
End Sub
 
'与えたセル範囲の列幅の合計を取得
Function GetMergeWidth(ByVal Rng As Range) As Double
    Dim pCol As Range
 
    For Each pCol In Rng.Columns
        GetMergeWidth = GetMergeWidth + pCol.ColumnWidth + 0.66
    Next
End Function
  
元のコードは汎用的に使えるよういろいろなチェックをしてますが、
考え方をシンプルに、単に値を転記してオートフィットしてみました。
(難しく考えなくてもこの程度でいいのでは?と考えました)
  
結果に不都合があっても、自己責任でご使用願います。
オートフィットが出来るようにしたけど、
多分、オートフィット出来たところで文字切れは発生したと思います。
印刷プレビューで要確認

回答
投稿日時: 18/02/01 17:58:57
投稿者: もこな2

>mattuwan44さん
翻訳&解読おつかれさまです。
英語?嫌いだしコード全然読む気がおきませんでしたが、こうなってたんですね。
とりあえず、やたらIF文がネストしてるなぁって感じですね。(Andでつなげば良さそうにおもいますが・・・)
 
>papatoさん

引用:
私の文中のコードですと(どういう仕組みがわからないんですが)何行分でもきれいにフィットしました。
同じ悩みを抱えていらっしゃると聞いて、がぜん探究し甲斐のあるイシューなんだな、と感じました。引き続き何か発見等ありましたらご共有いただけると幸いです。
すみません。失礼な言い方になりますが、人任せにせず、ご自身で研究してください。
 
そういう意図はないんだとおもいますが、今提示されてる内容だと、
 ・他人が作ってよくわからないコードがあります。
 ・うまく動くように解析して改造してください。
って読めちゃいます。
 
わからない部分があって、それが回答者でわかることであれば、みなさん丁寧に回答してくださるとおもいますけど、わからない部分がわからないとアドバイスのしようがありません。
 
ちなみに、結合範囲のデータを1セルにいれて、オートフィットしてみるっていう作戦は実行してみたんでしょうか?
調べてみたところ1セルの最大幅は255文字、最大高は409ポイントのようですから、これを超えないのであれば、作戦は無事成功するんじゃないかとおもいます。
他人が作ってよくわからないと仰るコードだけ提示されて、肝心のどのようなデータを処理したいのか(平均で3000文字ほどあるとか、改行コードが含まれるとか)が抜けているので、回答者側では(すくなくとも私は)これ以上アドバイスできないです。
 

投稿日時: 18/02/02 08:42:45
投稿者: papato

WinArrowさん、もこな2さん、simpleさん、mattuwan44さん、わかりにくく、他人任せな質問にもかかわらず、素通りせずにご指摘・ご回答くださり本当にありがとうございます。
 
特に、mattuwan44さん、2番目のご回答で、印刷プレビュー見ながら微調整してうまく作動しました。おかげさまで何時間もかかる作業が自動で行うことができました。マイクロソフトさんも、mattuwan44さんのコード採用して次回のエクセルアップデート時に適用させればいいのに、と思う次第です。本当にありがとうございました!