質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.37%

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

受付中

回答 5

投稿

  • 評価
  • クリップ 1
  • VIEW 6,456
退会済みユーザー

退会済みユーザー

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

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

イメージ説明
イメージ説明

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

[考えた方法]

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

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

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

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


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

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

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

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

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

コード

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

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

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

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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • torisan

    2019/07/30 11:29

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

    キャンセル

  • 退会済みユーザー

    退会済みユーザー

    2019/07/30 16:22

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

    いいえ、ございません。

    キャンセル

回答 5

+1

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

で行けます。

空白欄を選択しておくと意図しない動きをすることがあります。
(例:4列目までしか無い時に、5列目を選択していると1~5列目が選択される)

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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/07/30 21:43

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

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

    キャンセル

  • 2019/07/31 08:10

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

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

    キャンセル

  • 2019/07/31 19:17

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

    こちらは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を返しますね。

    キャンセル

+1

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

こういう場合は、
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


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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

+1

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

+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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

0

最終行、最終列だけではなく、最初の行と列も不明という条件のように思いますが、一番左上は固定で良いのでしょうか?
例えば、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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.37%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る