複数行を条件にしたがいまとめる

重複しているデータを行ごと統合します。

データベースでいうところの主キーが重複して存在するテーブルライクなExcelシートのデータを、主キー制約に違反しない形へまとめて別シートへ、というのが今回のあらすじです。

概要

そもそも、そんな処理が必要になった経緯。Microsoft Office365にはFormsという機能があります。アンケートとかクイズを作成してWEB上で公開して結果を集計できます。こんな感じにブラウザーから参加できます。

row_join1.png

Microsoftのサーバー上でWEBアプリとして動作するため自分のサーバーを持つ必要はありません。

実際に私が作成したアンケートにコチラから参加できます。結果も公開できてコチラからご覧いただけます。

この結果はExcel形式でダウンロードできて、いろいろ使い回すのに便利です。ただ、フォームを作成するのにWEB上で手打ちするしかなかったり、結果もダウンロードボタンからしか取得できなかったりと、まだまだ発展途上感はあります。

Googleにも似たようなサービスがあるようですが、Googleだったらデータをアップロードして一気に作成できて、APIで結果を取得できるようにしているに違いない、と思いつつもFormsを利用さぜるを得ない状況もあるわけです。

さて、結果データですが、次のような一人の回答が1行に記録された形式でExcelファイルとして取得できます。

row_join2.png

画像では匿名になっていますが、ログイン必須にするとMicrosoftアカウントのメールアドレスも記録され、誰が回答したのか判別できます。

ここからが本題で、回答は間違って一人が複数回送信したり、途中で送信してしまい、あとから続きを回答して再度送信したりといったことが起こりえます。要は一人1行であってほしいのが、ダブりや分割記録で一人の回答データが複数行存在している場合があるということです。

これらのデータを本来あるべき一人1行の状態へ統合しシートへ書き出す処理を考えます。

複数行を統合する方法を考える

行を統合するということは、何らかの基準をもって、それらが重複しているという判定をしなければなりません。今回はメールアドレスとなります。

状態としては次の3パターンがあります。

1.完全にデータが重複している

row_join3.png

2.データの重複はないが複数行に分かれている

row_join4.png

3.データが更新されている

row_join5.png

1、2については考えるまでもなく合体させるだけです。問題は3で、ルールを決めて一方を選択する必要があります。常識的には後からのデータを優先すべきですね。そうします。

まとめると
・どちらか一方にだけ値があれば、それを保持
・両方に値が存在すれば、時間的に後からの値を保持

すればいいことになります。

これらを適用して各自に一意の回答データを得るには、関数やフィルターでは難しいでしょう。なんとなくExcelのデータ分析系機能でもできそうな気もするのですが、現時点で私が知る方法はありません。今からその方法を知る労力より、今持てる知識を使う労力の方が安そうです。

デジタルデータはそれを得るまでの過程は品質に一切関係しません。この「手段は問わない」的なところがデジタルのいいところですね。

方法としては定番のVBAと、このサイトのコンセプトであるExcel×Pythonでもやってみ…たかったのですが、VBAで力を使い果たしたのでまたの機会にします。

VBAで複数行を統合する

ルールは前段で決定しているので、それに従いプログラムしていきます。

うごきとしては、まずデータをアドレスと時刻でソートしておきます。そして最新の値を保持しておくためのバッファー配列を用意します。

Formsデータのシートを2行単位で下へ走査していって、対象行の上下で違うアドレスであれば(ソートしてあるのでそれ以上同じアドレスが出る可能性はゼロなので)何もしないで出力シートへ送ります。

上下が同じアドレスであれば上の行のデータをバッファー配列へ確保します。以降は同じアドレスが続く間、バッファー配列とセル値を比較してバッファー配列を更新していきます。

アドレスが違う値になったら、バッファー配列を出力シートへ書き出しバッファー配列をクリアします。

これを延々繰り返していきます。

可視化するとこうなります。
bufが実際にはメモリ上にある配列です。outが出力用シートです。

row_join6.png

赤枠が走査中のデータです。

row_join7.png

row_join8.png

ここまではアドレスが違うのでそのまま出力シートへ出します。

同じアドレスがありました。bufにデータを確保します。

row_join9.png

同じアドレスが続く間はbufと比較されます。bufが更新されていきます。

row_join10.png

アドレスが違うものになったら、bufを出力シートへ書き出します。

row_join11.png

この要領で最後のデータまで統合していきます。

ソースコードは次のようになりました。

Option Explicit
    
Enum FORMS_COL
    START_DATETIME = 2
    END_DATETIME
    MAIL_ADDRESS
End Enum

Const FORMS_PAYLOAD_START_ROW As Long = 2
Const OUTPUT_START_ROW As Long = 2

Sub dataJoin(wbPath As String)
    Dim formsBook As Workbook
    Set formsBook = Workbooks.Open(wbPath)
    Dim formsSheet As Worksheet
    Set formsSheet = formsBook.Worksheets(1)
    Dim outputSheet As Worksheet
    Set outputSheet = ThisWorkbook.Worksheets("join")
    Dim dataSheet As Worksheet
    Set dataSheet = ThisWorkbook.Worksheets("data")

    Dim buf()
    
    Dim fr As Range
    Set fr = formsSheet.Range("a1").CurrentRegion
    
    Dim maxCol As Long
    maxCol = fr.Columns.Count
    Dim maxRow As Long
    maxRow = fr.Rows.Count
    
    'header
    Range(outputSheet.Cells(1, 1), outputSheet.Cells(1, maxCol)).Value = Range(formsSheet.Cells(1, 1), formsSheet.Cells(1, maxCol)).Value
    
    'data
    Range(dataSheet.Cells(1, 1), dataSheet.Cells(maxRow, maxCol)).Value = fr.Value
    
    'sort
    With dataSheet
        .Range("a1").CurrentRegion.Sort _
            key1:=.Cells(1, FORMS_COL.MAIL_ADDRESS), order1:=xlDescending, _
            key2:=.Cells(1, FORMS_COL.END_DATETIME), order2:=xlAscending, _
            Header:=xlYes
    End With
    
    ReDim buf(1 To 1, 1 To maxCol)
    
    Dim i As Long
    i = FORMS_PAYLOAD_START_ROW
    Dim j As Long
    Dim k As Long
    k = OUTPUT_START_ROW
    
    'アドレス列を下へ走査していく
    'アドレスを上下の行で比較して同じ場合はデータをバッファー配列に確保
    'アドレスが同じ間はルールに従いバッファーとセル値を比較、バッファー書き換え
    'アドレスが変わったらバッファーを出力シートへ書き出し
    Do
        i = i + 1
        Dim upperAddress As String
        Dim lowerAddress As String
        Dim upperRange As Variant
        Dim lowerRange As Variant
        upperAddress = dataSheet.Cells(i - 1, FORMS_COL.MAIL_ADDRESS).Value
        lowerAddress = dataSheet.Cells(i, FORMS_COL.MAIL_ADDRESS).Value
        
        If upperAddress = lowerAddress Then
            If IsEmpty(buf(1, 1)) Then
                upperRange = Range(dataSheet.Cells(i - 1, 1), dataSheet.Cells(i - 1, maxCol))
            Else
                upperRange = buf
            End If
            
            lowerRange = Range(dataSheet.Cells(i, 1), dataSheet.Cells(i, maxCol))
        
            For j = 1 To maxCol
                If lowerRange(1, j) = "" Then
                    buf(1, j) = upperRange(1, j)
                Else
                    buf(1, j) = lowerRange(1, j)
                End If
            Next
        Else
            If IsEmpty(buf(1, 1)) Then
                Range(outputSheet.Cells(k, 1), outputSheet.Cells(k, maxCol)).Value = Range(dataSheet.Cells(i - 1, 1), dataSheet.Cells(i - 1, maxCol)).Value
            Else
                Range(outputSheet.Cells(k, 1), outputSheet.Cells(k, maxCol)).Value = buf
            End If
            
            k = k + 1
            ReDim buf(1 To 1, 1 To maxCol)
        End If
    Loop Until dataSheet.Cells(i, 1).Value = ""
    
    formsBook.Close
End Sub

対象のFormsデータファイルはファイルを開くダイアログなどから取ってきたパス文字列を引数で渡す設計です。配列まわりとか条件分岐とか無駄が多そうな感じで、もっとリファクタリングできると思うのですが、今のところお腹いっぱいです。

一つだけつまづいたところがあって、Formsデータファイルのシートをわざわざ自分のブックにコピーしてからソートしています。コードの次の部分です。

Range(dataSheet.Cells(1, 1), dataSheet.Cells(maxRow, maxCol)).Value = fr.Value
    
With dataSheet
    .Range("a1").CurrentRegion.Sort _
        key1:=.Cells(1, FORMS_COL.MAIL_ADDRESS), order1:=xlDescending, _
        key2:=.Cells(1, FORMS_COL.END_DATETIME), order2:=xlAscending, _
        Header:=xlYes
End With

こんなことせずにFormsデータファイルのシートをソートして、それを走査していくつもりで

With formsSheet ’←ここが変わってます
    .Range("a1").CurrentRegion.Sort _
        key1:=.Cells(1, FORMS_COL.MAIL_ADDRESS), order1:=xlDescending, _
        key2:=.Cells(1, FORMS_COL.END_DATETIME), order2:=xlAscending, _
        Header:=xlYes
End With

とやろうとしたんですが、できません。実行時エラーでコケます。

row_join15.png

1mmも参考にならないエラーメッセージを出しやがります(VBAあるある)。それはわかってるから何で失敗したのかを言えやと。他言語のStack Traceがいかに良くできたしくみかを実感せざるを得ません。

デバッグで止めてローカルウィンドウでチェックしても型やパラメータはまったく問題ないように見えます。どうも別ブックにあるRangeだとお気に召さない様子。私の理解が根本的に間違っているのかもしれませんが、これ以上この問題の解決に労力をかけるのは割に合わないのでデータを丸ごと自前のシートに持ってきてやるようにしました。美しくないです。

VBAを仕込んだファイルをページ下部からダウンロードできます。

使用方法

1.ダウンロードボタンからファイルを入手します。

2.Formsからデータファイルをダウンロードします。

3.ファイルパスのセルをダブルクリックするとファイル選択ダイアログが開くのでFormsからダウンロードしたファイルを選択します。

row_join12.png

4.実行ボタンを押します。

row_join13.png

結果はjoinシートに記録されます。

row_join14.png

比較条件を変えたり、値を保持するルールを変えたりすれば、他の用途でも使えるかもしれませんね。

ファイルを入手する

利用上のご注意
  • ダウンロードしたファイルを利用したことにより生じた結果については、利用者ご自身に責任を負っていただきます。
  • ご利用前に使用方法をご確認ください。
  • 当方は成果物の正確性について最善を尽くしますが保証はいたしません。
  • Windows10-64bit Excel2016-32bit環境でのみ動作確認済み。

row_data_join.xlsm

DOWN LOADボタンが押下された時点で注意事項に同意したものとみなします。

related pages
Power AutomateでExcelシートのリストからメールを送信する Part2
Power Automateで条件によって処理を変える方法。

前回の自動メール送受信管理簿のつづきです。Power Automateでは条件を判定して、その結果により処理を変えるには条件分岐コントロールを使います。VBAでいうところのIfに相当します。条件分岐コントロールでは条件とTrueの場合、Falseの場合のパラメーターを設定していきます。

Read More ...
PCのカメラでバーコードを読み取りExcelに取り込む
Excelシートでバーコードによる物品管理を企むの巻。

VBAではバーコードの扱いは何とかなるにしても、カメラは絶望的です。世界は広いのでVBAから使えるカメラ制御DLLがあるのかもしれませんが、あったとしても私の技量では扱える気がしないので早々にあきらめ、Pythonでやります。

Read More ...
Excel-VBAでクラスを使って機能を拡張する
Workbookオブジェクトに機能を追加して便利に。

どの言語にも何回も登場する定番のコードというのがあります。はたらきたくないという思いに関しては誰にも負ける気がしない私は、この何回も同じことを書くという行為が嫌で何とかできないかと試行錯誤してきました。たどり着いたひとつの答えがクラスを使って機能を定義しておくという方法です。

Read More ...
この記事の
作成日

2020-04-29

更新日

2020-04-30

ページ内検索
目次
WEB MASTER
さいた
神エクセル撲滅協会理事(自称)
さいたま市民 埼玉こそ地上の楽園