[Excel VBA]別シートから測定データだけを引っこ抜きたい

はじめに

• 私は実験をメインに行う大学院生（2020年11月現在）です．
• 条件の振り方によっては，大量のデータが得られることがあります．
• 少しでも解析を楽にしたいのと，個人的な趣味とで，時々Excelのマクロを組みます．
• 忘れっぽいので，気が向いたときにQiitaにまとめています．

状況説明

適当な例として，250 K, 300 K, 350 Kの三条件で温度依存性のデータを取った場合を考えます．

過去に「マクロの乗ったExcelファイルと同じディレクトリにあるcsvファイルを全て読み込むやつ」を作っているので，これを使って3つのcsvファイルを一つのワークブックにまとめます．

ここで，ワークシート「Data1」は以下のようになっています．

V1とかI1はそれぞれ，電圧とか電流を想定して書いています．

やりたいこと

新しく「Summary」というワークシートを作り，そこに(i)と(iii)だけ引っこ抜いていきたい．

上の画像だけ見ると，シンプルにA11からF22までの範囲をコピーすればいいじゃんという気がする．しかし，条件を変えると「(iii) 測定データ」の範囲が変わってしまう．具体的には，

• V1の掃引範囲を1~10でなく，1～20にすると(iii)が縦に伸びる
• 記録する変数をV1, I1だけにすると，(iii)が横に縮む
• 「(ii) 測定条件など」の範囲は測定によって変わるので，(iii)の開始位置が必ずA11になる保証はない

なので，今回やりたいことは 各測定データに応じて「(iii) 測定データ」の範囲を検出し，「(i)オリジナルのファイル名」とセットで「Summary」というワークシートにコピーしてくる です．

アプローチ

幸いなことに，「(iii) 測定データ」は，必ず一番下に来ることが決まっています．
「(ii) 測定条件など」と「(iii) 測定データ」の順番が入れ替わることはありません．

また，測定データは左詰めで記録されるので，左端の列番号は必ず「1」になります．

なので，以下のようにマクロを組めば，やりたいことができるはずです．

1. ユーザーにワークシート名を入力してもらう（ex. Data1）
2. ユーザーに変数名を一つ入力してもらう（ex. V2）
3. 指定されたワークシートから，入力された変数名が含まれる最も下のセルの行番号を取得（これをkey_ROWとする）

4.左上が(Row, Column) = (key_ROW, 1)に決まる
5. IsEmpty関数とDo Until文を使ってループさせることで，右下の(Row, Column)を取得
6. Range(Cells(左上)，Cells(右下))をSummaryワークシートにコピーする
7. 最後にA1のファイル名をSummaryワークシートにコピーする

マクロ

とりあえず動けばいいやのマクロが出来たのでそれを掲載．
今後細かいところを詰めるかもしれないし詰めないかもしれない．

Sub DynamicCopy()
    ' Worksheets
    Dim data_ws, summary_ws As Worksheet

    ' For iteration
    Dim i As Integer

    ' For searching data from data worksheet
    Dim key_RNG As Range
    Dim key_VAR As String
    Dim key_ROW, key_COL As Integer
    Dim firstAddress As String
    Dim Right, Bottom As Integer
    Dim Data_width, Data_length As Integer

    ' For copy data to summary worksheet
    Dim place_ROW, place_COL As Integer

    Dim DSname As String
    DSname = InputBox("Please enter datasheet name.", "DSname", "")

    Set data_ws = Worksheets(DSname)
    Set summary_ws = Worksheets("Summary")

    ' Input "key" variable name from user.
    key_VAR = InputBox("Please enter key variable.", "key_VAR", "")

    If key_VAR = "" Then
        MsgBox ("Please enter key variable name.")
        End
    End If

    ' First finding
    Set key_RNG = data_ws.Cells.Find(What:=key_VAR)

    If Not key_RNG Is Nothing Then
        firstAddress = key_RNG.Address
    Else
        MsgBox (key_VAR + " is not found.")
        End
    End If

    ' Continue finding
    key_ROW = key_RNG.Row

    Do While True
        Set key_RNG = data_ws.Cells.FindNext(key_RNG)     
        If key_RNG.Row > key_ROW Then
            key_ROW = key_RNG.Row
        End If

        If key_RNG.Address = firstAddress Then Exit Do
    Loop

    key_COL = 1

    ' Find right index
    ' And define "Data width"
    i = 1
    Do Until IsEmpty(data_ws.Cells(key_ROW, i)) = True
        i = i + 1
    Loop
    Right = i - 1
    Data_width = Right - key_COL

    ' Find bottom index
    ' And define "Data length"
    i = key_ROW
    Do Until IsEmpty(data_ws.Cells(i, 1)) = True
        i = i + 1
    Loop
    Bottom = i - 1
    Data_length = Bottom - key_ROW    

    ' Copy data
    place_ROW = 4
    place_COL = 3
    summary_ws.Range(summary_ws.Cells(place_ROW, place_COL), summary_ws.Cells(place_ROW + Data_length, place_ROW + Data_width - 1)).Value = _
    data_ws.Range(data_ws.Cells(key_ROW, key_COL), data_ws.Cells(Bottom, Right)).Value

    ' Copy dataname
    summary_ws.Cells(1, place_COL).Value = data_ws.Cells(1, 1).Value

End Sub

References

このマクロを作るにあたって，様々なWebサイトを参考にしました．ありがとうございます．

特に参考にしたものはこちら
条件に当てはまるセルを検索する(Find/FindNext/FindPreviousメソッド)