行高・列幅だけをコピーする

たぶんExcelのヴァージョン違いが原因だと思うのだけれど……。

ラベル用紙に印刷できるように設定してあったシートの寸法がめちゃくちゃになってしまった……。

とりあえず、原本から行高と列幅だけをコピーしたかったのだが、サクッとできる方法が思いつかなくて、結局マクロを書いてしまった。たぶん、いつもの「車輪の再発明」とは思いながら……。

行高・列幅だけをコピーするメソッド

あまりむつかしく考えずに、引数で受け取った〈範囲１〉の行高・列幅を〈範囲２〉に適用する、というものにした。

リスト１

Public Function copyHeightWidth( _
            ByVal range1 As Range, _
            ByVal range2 As Range) As Boolean
  copyHeightWidth = False
  'ガード節：二つのセル範囲の大きさが違ったらFalseを返す'
  If range1.Columns.Count <> range2.Columns.Count Or _
     range1.Rows.Count <> range2.Rows.Count Then Exit Function
  '行高をセット'
  Dim i As Long
  For i = 1 To range1.Rows.Count
    range2.Rows(i).RowHeight = range1.Rows(i).RowHeight
  Next
  '列幅をセット'
  For i = 1 To range1.Columns.Count
    range2.Columns(i).ColumnWidth = range1.Columns(i).ColumnWidth
  Next
  copyHeightWidth = True
End Function

短いコードなので、説明は簡単に。

単純に、行、列別に、range1のRowHeight、ColumnWidthプロパティの値を、range2のRowHeight、ColumnWidthプロパティにセットしているだけ。

使ってみる

次のコードで使ってみる。

リスト２

Private Sub testCopyHeightWidth()
  Const RANGE_ADDRESS As String = "$A$1:$E$5"
  Dim range1 As Range
  Set range1 = Sheet1.Range(RANGE_ADDRESS)
  Dim range2 As Range
  Set range2 = Sheet2.Range(RANGE_ADDRESS)
  If Not copyHeightWidth(range1, range2) Then Exit Sub
End Sub

最近、定数をホントによく使うようになったなあ。

結果をGIF動画で示す。

f:id:akashi_keirin:20191007071500g:plain