VBA amacoda

購入者を重複なくリストアップしたシートを挿入 – プロシージャはできるだけ分割したほうがいい

Insert the worksheet that list the customer and does not include duplicated records

 

購入者リストを作りたい

会社で購入者リストを作る機会がありました。

日付順に入力された売上明細から、重複なく購入者をリストアップすることが求められています。

購入者リストには最新の購入明細を使用することにします。

リストには、購入日・会員番号・氏名・店番・店名・品名・単価・数量・金額が含まれています。

・動作は無保証です。
・動作確認は、Windows 10 + Excel 2016、Windows 7 + Excel 2010でおこなっています。
・ファイルはここからダウンロードしてください。

 

ソースコードをながめてみる

Option Explicit

Public Sub S_InsertWorksheetInvolvingSortedData_Main()
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Worksheets("Input").Copy After:=Worksheets("Input")
    Dim myWS As Worksheet: Set myWS = ActiveSheet
    
    myWS.Name = F_InsertWorksheetInvolvingSortedData_Core(myWS)
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Private Function F_InsertWorksheetInvolvingSortedData_Core _
    (ByVal WS As Worksheet) As String
    With WS
        Dim myRow As Long
        myRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        Dim myDate As String
        myDate = CStr(Format(.Cells(myRow, 1), "ee.mm.dd"))
        
        Dim i As Long
        For i = 1 To Worksheets.Count
            If Worksheets(i).Name = myDate Then
                Worksheets(i).Delete
            End If
        Next i
        
        Call S_SortWorksheetData(WS, myRow)
        
        Call S_DeleteDuplicativeRows(WS, myRow)
        
        Call S_SortWorksheetData2(WS, myRow)
        
        myRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Cells(myRow, 1).Offset(1, 0).Activate
        
        F_InsertWorksheetInvolvingSortedData_Core = myDate
    End With
End Function

Private Sub S_SortWorksheetData(ByVal WS As Worksheet, ByVal myRow As Long)
    With WS.Sort
        With .SortFields
            .Clear
            .Add _
                Key:=WS.Range(WS.Cells(2, 4), WS.Cells(myRow, 4)), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortTextAsNumbers
            .Add _
                Key:=WS.Range(WS.Cells(2, 1), WS.Cells(myRow, 1)), _
                SortOn:=xlSortOnValues, _
                Order:=xlDescending, _
                DataOption:=xlSortNormal
        End With
        
        .SetRange WS.Range(WS.Cells(1, 1), WS.Cells(myRow, 9))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
End Sub

Sub S_DeleteDuplicativeRows(ByVal WS As Worksheet, ByVal myRow As Long)
    If WS.Name <> "Input" Then
        With WS
            Dim i As Long
            For i = myRow To 3 Step -1
                If .Cells(i, 4).Value = .Cells(i - 1, 4).Value Then
                    
                    .Cells(i, 1).EntireRow.Delete
                    '.Range(.Cells(i, 1), .Cells(i, 9)).EntireRow.Delete
                    '.Rows(i).Delete
                End If
            Next i
        End With
    End If
End Sub

Private Sub S_SortWorksheetData2(ByVal WS As Worksheet, ByVal myRow As Long)
    With WS.Sort
        With .SortFields
            .Clear
            .Add _
                Key:=WS.Range(WS.Cells(2, 1), WS.Cells(myRow, 1)), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
        End With
        
        .SetRange WS.Range(WS.Cells(1, 1), WS.Cells(myRow, 9))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
End Sub

メインプロシージャは、「S_InsertWorksheetInvolvingSortedData_Main」。全体をコントロールします。

このプログラムの中心部分が「F_InsertWorksheetInvolvingSortedData_Core」というファンクションプロシージャ。このプログラムで重要な2つの変数に値を与え、3つのサブプロシージャをコントロールします。

「S_SortWorksheetData」「S_DeleteDuplicativeRows」「S_SortWorksheetData2」は、並べ替えや重複データの削除をそれぞれ担当します。

 

メインプロシージャにはなにが書いてあるか

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

このコードは、プログラムの高速化・自動化のために必要になります。

Worksheets("Input").Copy After:=Worksheets("Input")

日付順に入力された売上明細「Input」シートの後ろ（右側）に「Input」シートをコピーします。

Dim myWS As Worksheet: Set myWS = ActiveSheet

コピーされたシートの名前は「Input (2)」となり、シートはアクティブになります。そのアクティブなシートをオブジェクト変数「myWS」に代入します。

myWS.Name = F_InsertWorksheetInvolvingSortedData_Core(myWS)

このプログラムの中心部分であるプロシージャは、サブプロシージャではなく、ファンクションプロシージャになっています。そのファンクションプロシージャの戻り値を「myWS」シートの名前に代入します。

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

プログラムの高速化・自動化のための設定を元に戻します。

 

このプログラムのコア（中心）となるファンクションプロシージャとは

With WS
～～～～～～
End With

引数でもらったオブジェクト変数の「WS」シートについての処理をおこないます。

Dim myRow As Long
myRow = .Cells(.Rows.Count, 1).End(xlUp).Row

このプログラムで一番重要な変数です。「売上明細」シートの最終行の行数を取得し、変数「myRow」に代入します。

Dim myDate As String
myDate = CStr(Format(.Cells(myRow, 1), "ee.mm.dd"))

最終行のA列のセルの日付を変数「myDate」に代入します。その際に「Format」関数で書式を「ee.mm.dd」に変換し、「CStr」関数でString型にデータ型を変換します。

Dim i As Long
For i = 1 To Worksheets.Count
    If Worksheets(i).Name = myDate Then
        Worksheets(i).Delete
    End If
Next i

このブックの中に、変数「myDate」の文字列（日付）と同じ名前のシートがある場合、それを削除します。

これからその名前をシート名に使うため、あらかじめ同じ名前を持つシートを削除しておきます。

Call S_SortWorksheetData(WS, myRow)

Call S_DeleteDuplicativeRows(WS, myRow)

Call S_SortWorksheetData2(WS, myRow)

ワークシートのオブジェクト変数「WS」とワークシートの最終行の変数「myRow」を3つのサブルーチンに渡して、それぞれの作業をおこなわせています。

myRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(myRow, 1).Offset(1, 0).Activate

再度、「売上明細」シートの最終行の行数を取得し、変数「myRow」に代入し、その１行下のセルを選択します。

F_InsertWorksheetInvolvingSortedData_Core = myDate

ファンクションプロシージャ名と同じ名前の変数「F_InsertWorksheetInvolvingSortedData_Core」に日付の文字列変数「myDate」を代入します。

機能的にみると、「F_InsertWorksheetInvolvingSortedData_Core」という１つの文字列を、ファンクションプロシージャの名前として使い、変数名としても使っている、といえます。

 

並べ替えをするプロシージャとは

With WS.Sort
    ～～～～～～～～～～～～～～～～
End With

引数でもらったワークシート変数の「WS]シートについて、並べ替えをあらわす「Sort」オブジェクトについて操作します。

With .SortFields
    .Clear
    .Add _
        Key:=WS.Range(WS.Cells(2, 4), WS.Cells(myRow, 4)), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortTextAsNumbers
    .Add _
        Key:=WS.Range(WS.Cells(2, 1), WS.Cells(myRow, 1)), _
        SortOn:=xlSortOnValues, _
        Order:=xlDescending, _
        DataOption:=xlSortNormal
End With

並べ替えをキーを設定します。最初に、「Clear」メソッドで直前のキーを消去します。次に「Add」メソッドでキーを追加します。

「Key」パラメータは並べ替えのキーの値を設定します。通常は、セル範囲を指定します。ここでは、「WS.Range(WS.Cells(2, 4), WS.Cells(myRow, 4))」としています。
「WS」を何度も使っていることに注目してください。
この文は「Sort」オブジェクトの「With」文の中にありますので、「Range」プロパティや「Cells」プロパティの親オブジェクトを正確に指定する必要があります。
もし、「WS」を省略して「.Range(WS.Cells(2, 4), .Cells(myRow, 4))」とすると、親オブジェクトは「WS.Sort」となり、エラーが発生します。
しかし、例外があります。「WS.」、「WS」と「ピリオド」を省略すると、親オブジェクトはアクティブシートとなります。ここで、もし「WS]がアクティブシートであれば、エラーは発生せず、並べ替えはうまくいきます。
もし、「WS]がアクティブシートでない場合、別のシートがアクティブとなり、並べ替えは思わぬ結果をもたらすことになるかもしれません。
ですので、最初はこの例外を当たり前と思っていてもいいですが、学習が進んできたら、正確な知識を大切にしましょう。

「SortOn:=xlSortOnValues」で並べ替えの対象を指定します。ここでは、セルの値を対象に並べ替えます。

「Order:=～～～」は、並べ替えの順序を決定します。4列目、D列は「xlAscending」は昇順で並べ替え、1列目、A列は「xlDescending」は降順で並べ替えをします。

「DataOption:=～～～」はテキストを並べ替える方法を指定します。4列目、D列は「xlSortTextAsNumbers」はテキストを数値データとして並べ替え、1列目、A列は「xlSortNormal」は数値とテキストを別々に並べ替えをします。

.SetRange WS.Range(WS.Cells(1, 1), WS.Cells(myRow, 9))

並べ替えが行われる範囲を設定します。セル「A1」から「I」列の最終行までを並べ替えの範囲としています。
セルの表示形式には「A1」形式と「R1C1」形式がありますが、使い分けの基準はプログラムを使うかどうかです。
プログラムを使う、書くというときは「R1C1」形式を使い、そうでなく、ワークシートを使うときは「A1」方式を使うのがいいでしょう。

.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply

「.Header = xlYes」で1行目をタイトル（ヘッダ）に指定し、「.MatchCase = False」で大文字・小文字の区別をしない、ということを指定し、「.Orientation = xlTopToBottom」並べ替えの方向を「行」に指定し、「.Apply」でこれらの設定を適用（実行）しています。

 

重複した行を削除するには

If .Name <> "Input " Then
～～～～～～～～～～～～～～～～
End If

シート名が「Input」以外のときに重複した行を削除します。

Dim i As Long
For i = myRow To 3 Step -1
    If .Cells(i, 2).Value = .Cells(i - 1, 2).Value Then
　　　　～～～～
    End If
Next i

重複行を削除するためにループを回すときは、最終行から先頭行へとループを回します。

当該行と1つ上の行を比較するので、先頭行は3行目とします。比較する最後の行は3行目と2行目ということになります。

ここでは、会員番号を表す「B列」、2列目に注目し、重複行を探しています。

.Cells(i, 1).EntireRow.Delete
'.Range(.Cells(i, 1), .Cells(i, 9)).EntireRow.Delete
'.Rows(i).Delete

この3つの命令はいずれも重複行を削除する命令です。どれが正しくてどれが間違っているということはなく、3つの命令を使いこなし、適切に使い分けることが必要です。

 

ふたたび、並び替え

With WS.Sort
    With .SortFields
        .Clear
        .Add _
            Key:=WS.Range(WS.Cells(2, 1), WS.Cells(myRow, 1)), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
    End With
    
    .SetRange WS.Range(WS.Cells(1, 1), WS.Cells(myRow, 9))
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .Apply
End With

上述の部分では、「日付」をキーにし、降順で並び変えましたが、それは一番古いデータを残すためでした。今度は、「日付」をキーにし、昇順で並び替えます。

 

実は、もっと簡単な方法が

このプログラムでは、重複行削除の部分でいわゆる「枯れた」技術を使っています。ループの中で該当行とその1つ上の行を比較して重複がある場合、該当行を削除するというものです。

ところが、Excel 2007以降、新しい技術が出てきました。「RemoveDuplicates」メソッドがそれです。ループを使うのに比べて、たった1つの命令文で足ります。

Sub S_DeleteDuplicativeRows2(ByVal WS As Worksheet, ByVal myRow As Long)
    With WS
        If .Name <> "Input" Then
            .Range(.Cells(1, 1), .Cells(myRow, 9)).RemoveDuplicates _
                Columns:=2, Header:=xlYes
        End If
    End With
End Sub

「Columns」パラメータは、重複を確認する列を指定します。2列目と4列目を確認するならば、「Columns:=Array(2, 4)」とします。「Header」パラメータは、1列目をタイトル（ヘッダ）とするかどうかを指定します。「はい」なら「xlYes」を指定します。「いいえ」なら「xlNo」ですが、既定値ですので、わざわざ書く必要はありません。Excelにヘッダーを判断させるには、「xlGuess」を指定します。

 

おわりに

今回はそんなに難しいプログラムではありませんでした。しかし、できる限り分割してみました。今回1番理解していただきたいのは、プロシージャの分割です。
わたしは、14インチのThinkpad X1 Carbonを使っていますが、その小さな画面でも1つ1つのプロシージャが1つの画面に収まりました。みなさんもできる限り、プロシージャを分割してみてください。

コメントを残す

RECOMMENDこちらの記事も人気です。