ExcelVBAで、空白がある表を範囲指定してコピーしたい

Question

VBAエキスパートの資格を取るため、勉強中です。
今回、ExcelVBAで範囲指定をしてコピーするためのコードを練習しているのですが、以下、１点分からないところがあります。

[やりたいこと]
画像１と２のように、空白がところどころに入っている表をコピーできるようにしたいです。
また、どこに空白があるかは分からないものとします。

この場合、タイトルは除きます。

[考えた方法]

空白がどこにあるか分からない表をコピーする方法としては、まず

1. 表の最終行を取得する
2. 表の最終列を取得する
3. 最終行と最終列を使って範囲指定してコピー

という方法が考えられると思いました。
この場合、まず表の最終行を取得するコードを考えないといけないのですが、

'表の最終行を取得（５列目）
endcol = (Cells(Rows.Count, 5).End(xlUp).Row)

というコードを使って列を指定してその行の最終行を取得するコードがあることを知りました。

ですが、今回の場合はどこで空白があるか分からないため、行を指定してその行の最終行を取得するということは難しいと思います。

そこで、例えば最終行取得ならば１列ごとにその列の最終行を取得し、その中で一番大きな数字を表の最終行とする方法を考えました。

コードは以下の通りです。

Option Explicit

'名前の定数=====================================================
Const stroutput_FName As String = "練習.xlsb"
Const stroutput_SheetName As String = "テスト"
Sub test()

Dim wboutput As Workbook                'アウトプットファイル格納
Dim wboutput_Sheet As Worksheet         'アウトプットファイルのシート

Dim endcol As Integer
Dim endcol_1 As Integer
Dim endcol_2 As Integer
Dim endcol_3 As Integer
Dim endcol_4 As Integer

Dim endrow As Integer
Dim endrow_1 As Integer
Dim endrow_2 As Integer
Dim endrow_3 As Integer
Dim endrow_4 As Integer


    'アウトプットファイルのファイルパスを取得
    Workbooks.Open ThisWorkbook.Path & "\" & stroutput_FName
    Set wboutput = ActiveWorkbook
    Set wboutput_Sheet = ActiveWorkbook.Worksheets(stroutput_SheetName)
    

    '最終行をチェック
    endcol_1 = (Cells(Rows.Count, 1).End(xlUp).Row)
    endcol_2 = (Cells(Rows.Count, 2).End(xlUp).Row)
    endcol_3 = (Cells(Rows.Count, 3).End(xlUp).Row)
    endcol_4 = (Cells(Rows.Count, 4).End(xlUp).Row)
        
    endcol = WorksheetFunction.Max(endcol_1, endcol_2, endcol_3, endcol_4)
    
    
    '最終列をチェック
    endrow_1 = Cells(1, Columns.Count).End(xlToLeft).Column
    endrow_2 = Cells(2, Columns.Count).End(xlToLeft).Column
    endrow_3 = Cells(3, Columns.Count).End(xlToLeft).Column
    endrow_4 = Cells(4, Columns.Count).End(xlToLeft).Column
    
    
    endrow = WorksheetFunction.Max(endrow_1, endrow_2, endrow_3, endrow_4)
    
    Range(Cells(1, 1), Cells(endcol, endrow)).Copy
    

End Sub

コード

ですが、この方法だと、行や列がたくさんある時はその都度変数をたくさん作っていかねばならず効率がとても悪いです。

そこで他にももっと良いコードがないか色々と調べましたが分かりませんでした。

今回のように、空白がどこにあるか分からない表の範囲を取得してコピーする良いコードはありますでしょうか？

ご教示よろしくお願いいたします。

Comments

[torisan]

その表があるシートには
別のデータ、別の表は存在しますか？

[退会済みユーザー]

はじめまして。興味を持って下さりありがとうございます。

いいえ、ございません。

Answer 1

手順としては
1行目は見出しで空白がないと前提するならば

手順1：1行目の一番右が何列目かを取得

max_column = Sheets("Sheet1").Range("A1").End(xlToRight).Column

手順2：手順1で取得した列数分forで最大行を取得

For roop = 1 To max_column
    max_row = Sheets("Sheet1").Cells(Rows.Count, roop).End(xlUp).Row
next roop

手順3：手順2のforの中で各列の最大行を比較して大きいものを変数に入れる。

max_num = 0
If max_num < max_row Then
            max_num = max_row
        Else
End If

手順4：手順3までで選択する範囲がわかるのでselectで範囲を指定

Range(Cells(2, 1), Cells(max_num, max_column)).Select

ざっくりこのような手順でできます。
表の列が増えても行が増えても対応できます。

ただし、1行目にも空欄が入る可能性があるなら手順は変わります。
また、表の開始が1列目でない場合も手順が少し変わります。

全体

Sub select_cell()
    
    
    Dim max_row As Long: max_row = 0
    Dim roop As Long
    Dim max_column As Long
    Dim max_num As Long: max_num = 0
    
    '表が1列目から始まっていて見出しに空白がないのが前提
    max_column = Sheets("Sheet1").Range("A1").End(xlToRight).Column

    
    For roop = 1 To max_column
        max_row = Sheets("Sheet1").Cells(Rows.Count, roop).End(xlUp).Row
        If max_num < max_row Then
            max_num = max_row
        Else
        End If
    Next roop
    
    Range(Sheets("Sheet1").Cells(2, 1), Sheets("Sheet1").Cells(max_num, max_column)).Select

    
End Sub

Answer 2

条件がわからないので
http://www.niji.or.jp/home/toru/notes/8.html
↑から適した物を探してみて下さい。

Answer 3

ですが、この方法だと、行や列がたくさんある時はその都度変数をたくさん作っていかねばならず効率がとても悪いです。

こういう場合は、
For～Next文で繰り返し列を移動しながら最終行を探索し、
If～Then～文で比較して大きい方を変数に書き換えて記録していきます。

こんな説明でわかりますか？

その後、質問者さんの反応がないけど、、、、
ループして最大値を探すのは、If～Then～や変数の使い方も含めて、基本中の基本なので、
自分で思いついて、自分で書けるようになりましょう。
この辺は経験なので、試験用の勉強だけでは辛いかもです。

他の方も書いておられますが、僕が書いたらこんな感じ、、、、

Sub test1()
    Dim rngTable As Range   '表のセル範囲（シート上の使用している範囲）
    Dim rngTarget As Range  'コピーしたいセル範囲
    Dim c As Range          '各セル
    Dim ix As Long          '行番号
    Dim ixMax As Long        '最大データ行番号
    
    '表のセル範囲を取得して変数に記録
    Set rngTable = Sheets("Sheet1").UsedRange
    
    '列毎に繰り返し見て行き最大データ行を調べる
    For Each c In rngTable.Columns
        ix = c.Cells(c.Cells.Count + 1, 1).End(xlUp).Row
        If ixMax < x Then ixMax = ix
    Next
    
    '取得した最大行番号でコピー
    With rngTable
        .Range(.Cells(2, 1), .Cells(ixMax + 1, .Columns.Count)).Copy
    End With
    
    '貼付
    With Sheets("Sheet2")
        .Paste .Range("A2")
    End With
End Sub

自分でループ処理を書かなければ、こんな感じですかね。。。

Sub test2()
    Dim rngTable As Range: Set rngTable = ActiveSheet.UsedRange
    Dim rngBottom As Range
    
    With rngTable
        With .SpecialCells(xlCellTypeConstants)
            Set rngBottom = .Areas(.Areas.Count).EntireRow
        End With
        Set rngBottom = Intersect(.Cells, rngBottom)
    End With
    Application.Range(rngTable.Rows(2), rngBottom).Select
End Sub

勘で書いたので、もしかしたら不具合があるかもです。
シート上の値の配置パターンにより、意図しない結果になる場合は、
その配置のパターンをお教え下さい。
暇があれば対応策を考えてみます。

Answer 4

range("A1").select
Selection.CurrentRegion.Select

で行けます。

空白欄を選択しておくと意図しない動きをすることがあります。
（例：４列目までしか無い時に、５列目を選択していると１～５列目が選択される）

追記
すみません１行目いらないんですね。
でしたら
range("A2").select
Range(ActiveCell, ActiveCell.SpecialCells(xlLastCell)).Select
でA2からの範囲で選択されます。

Comments

[mattuwan]

＞range("A1").select
＞Selection.CurrentRegion.Select
＞空白欄を選択しておくと意図しない動きをすることがあります。

今回の件の場合、セルを選択する必要がないので、
あえて選択しなくてもいいです。
「A1セルを含むアクティブな表をコピー」
と命令すればいいのです。
つまり、
range("A1").CurrentRegion.Copy
と命令すれば、セルの選択状況に左右されません。

ただし、今回の件の場合は、表の中に空白行がある可能性があるので、
CurrentRegion案は使えません。

それから、
SpecialCells(xlLastCell)
↑これはネットで検索してみるとわかると思いますが、
意図したセルが取得できずにトラブルの元になりますので、
別のアプローチを模索した方が無難です。

ちょっと気になったのでコメントしました。

[expy]

ですと普通にループさせる方が良いですね。

[meg_]

「SpecialCells(xlLastCell)」は正常に動作しないことがあるのでしょうか？
ネット検索したところ、10年程前の古いExcelでは起こっていたのか、またはブックを保存前に使用していた結果のようです。（Q&Aサイトの情報のため詳細不明）
手元の環境「Excel2013」では正しく最終セルが取れています。
今後のために、詳細をご存知でしたら教えてください。

[mattuwan]

そういえば、最近はその手の質問を見掛けませんね。
改善されたのかもしれませんが、他に確実な方法があるので、
SpecialCells(xlLastCell)をあえて使ってないので、分かりません。
ブックを保存する前に、シート上で編集行った後、
SpecialCells(xlLastCell)を使っても編集結果が反映されなかったように、
記憶してます。
回避するには、ブックを一旦保存するか、
UsedRangeプロパティを使用すると情報が更新されたように記憶してます。
気になるなら、個人で実験して探求してみてください。

個人的には、

with activesheet.usedrange
.cells(.cells.count).select
end with

とした方が確実だと思ってます。

[meg_]

現在のエクセルでは保存しなくても正しく最終セルを取れました。
但し「SpecialCells(xlLastCell)」にしても「Usedrange.cells(.cells.count)」にしても罫線が引かれたセルも対象になってしまいますね。
こちらの質問への対応は意外と大変ですね。

コメントありがとうございました。

[mattuwan]

>罫線が引かれたセルも対象になってしまいますね。
>こちらの質問への対応は意外と大変ですね。

そうですか？
「使っている範囲の内、2行目から、データの入っている最後の行」が
操作（コピー）の対象なのですから、
それさえ言語化できれば、方法論はいくつかあると思いますよ＾＾
SpecialCellsを使えばループ処理を書かなくてもよいかと思います。

[mattuwan]

＞現在のエクセルでは保存しなくても正しく最終セルを取れました。

こちらは2010ですが、不具合がやはりありますね。
Sub test()
Dim r As Range

MsgBox Cells.SpecialCells(xlCellTypeLastCell).Address(0, 0)

Range("B2:E5").Borders.LineStyle = True

MsgBox Cells.SpecialCells(xlCellTypeLastCell).Address(0, 0)

Range("A:B").Delete

MsgBox Cells.SpecialCells(xlCellTypeLastCell).Address(0, 0)

ActiveSheet.UsedRange

MsgBox Cells.SpecialCells(xlCellTypeLastCell).Address(0, 0)
End Sub

列を削除したあと、C5を取得して欲しいですが、
なにもないE5を返します。
UsedRangeと呪文を唱えると、
更新されてC5を返しますね。

Answer 5

最終行、最終列だけではなく、最初の行と列も不明という条件のように思いますが、一番左上は固定で良いのでしょうか？
例えば、A列にデータがなく、B列から始まる場合、コピーもB列からであると思いますが、どうなのでしょう。
念のため、下記のコードでは一番左の列と一番上の行も取得するようにしています。

質問者さんの例の場合、Cells.Findでセルに何らかの文字または数式があれば、そのセルのアドレスを検索して見るという手法が使えます。変則的なやり方ですが、使い方次第では、セルの内容に応じて取得するかしないかを選択できたり、色々おまけ機能も加えられますので、対応の幅が広がるメリットがあります。
このコードで取得できる値を使ってコピーをすると予想通りの動きにならないでしょうか。

Option Explicit

Sub GetFirstAndLastAddressNumber()
    
    Dim minRow As Long: minRow = Rows.Count     '一番上の行番号
    Dim maxRow As Long: maxRow = 2              '一番下の行番号
    Dim minCol As Long: minCol = Columns.Count  '一番左の列番号
    Dim maxCol As Long: maxCol = 1              '一番右の列番号
    
    Cells(1, Columns.Count).Select
    
    Cells.Find(What:="*", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, _
                SearchOrder:=xlByRows, SearchFormat:=False).Activate
    
    Do
        If minRow > ActiveCell.Row Then minRow = ActiveCell.Row
        If maxRow < ActiveCell.Row Then maxRow = ActiveCell.Row
        If minCol > ActiveCell.Column Then minCol = ActiveCell.Column
        If maxCol < ActiveCell.Column Then maxCol = ActiveCell.Column
        Cells.FindNext(After:=ActiveCell).Activate
    Loop While ActiveCell <> Range("A1")
    
    MsgBox "最上行：" & minRow & " 最左列：" & minCol & "最下行：" & maxRow & " 最右列：" & maxCol
    
End Sub