エクセルのマクロの質問です。誕生日登録をした顧客に誕生月の前月末に誕生日割引のDMを送っています。DMを送る顧客は誕生月以外に次の条件があります。

"DMの受け取りを拒否していない"、"直近1年間に1度でも購入している"、"過去3年間に2万円以上の買い物をしている"
この条件に該当する顧客を抽出するのに現在は一人ひとり検索して調べています。あるひと月に誕生日登録している顧客は600人ほどいるため非常に時間がかかっています。
これを何とかマクロで自動化できればと考えています。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
※文字制限のためサンプルデータ、仕様の詳細はこの下にある「この質問・回答へのコメント」に記載いたします。

回答の条件
  • 1人5回まで
  • 登録:2008/06/08 00:01:39
  • 終了:2008/06/08 11:53:59

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912008/06/08 02:12:00

ポイント1000pt

新しいご質問のようですので、回答してみました。


すべてのシートは同一ファイルにあるものとして作成しています。

Option Explicit

'--- 誕生日DM シートのセル情報
Const BS_SheetName = "誕生日DM"
Const BS_BaseDate_Range = "B1"    '--- 基準日入力セル
Const BS_BirthMonth_Range = "B2"  '--- 誕生月入力セル
Const BS_Result_Range = "B3"      '--- 結果表示セル


'--- 顧客名簿 シートの列情報
Const CS_SheetName = "顧客名簿"
Public CS_ID_Col
Public CS_MailAddress1_Col
Public CS_MailAddress2_Col
Public CS_BirthMonth_Col
Public CS_DM_Deny_Col

'--- 来店記録 シートの列情報
Const VS_SheetName = "来店記録"
Public VS_ID_Col
Public VS_Date_Col
Public VS_Price_Col

'---------------------------------------------------------------------
Sub ListUpDM()
'---------------------------------------------------------------------
    Dim cWS As Worksheet
    Set cWS = Worksheets(CS_SheetName)

    Dim bWS As Worksheet
    Set bWS = Worksheets(BS_SheetName)

    
'--- タイトル行の設定
    If initColData() = False Then
        Exit Sub
    End If

'--- 誕生月のチェック
    Dim birthMonth&
    birthMonth = CInt(bWS.Range(BS_BirthMonth_Range).Value)
    If Not IsNumeric(birthMonth) Then
        MsgBox "誕生月が数値ではありません。"
        Exit Sub
    End If

    If birthMonth < 1 Or birthMonth > 12 Then
        MsgBox "誕生月が1~12の範囲にありません。"
        Exit Sub
    End If

'--- 基準日のチェック
    Dim baseDate As Date
    baseDate = bWS.Range(BS_BaseDate_Range).Value
    If DateDiff("D", baseDate, Date) > 30 Then
        If MsgBox("基準日が30日以上前です。" & vbNewLine & "処理を続けますか?", vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
    Debug.Print DateDiff("D", baseDate, Date)
'--- タイトル行を顧客名簿の1行目からコピー
    cWS.Rows(1).Copy Destination:=bWS.Rows(4)
    bWS.Rows(5 & ":" & Rows.count).Clear

'--- 対象を検索
    Dim lastRow&, dstRow&, i&
    lastRow = cWS.Range(CS_BirthMonth_Col & Rows.count).End(xlUp).Row
    dstRow = 5
    For i = 2 To lastRow
        If cWS.Cells(i, CS_BirthMonth_Col) = birthMonth _
         And cWS.Cells(i, CS_DM_Deny_Col).Value = "" _
         And (cWS.Cells(i, CS_MailAddress1_Col) <> "" _
             Or cWS.Cells(i, CS_MailAddress2_Col) <> "") Then
            If doesCome(cWS.Cells(i, CS_ID_Col), baseDate, 1) Then
                If doesBuy(cWS.Cells(i, CS_ID_Col), baseDate, 3, 20000) Then
                    cWS.Rows(i).Copy Destination:=bWS.Rows(dstRow)
                    dstRow = dstRow + 1
                End If
            End If
        End If
    Next
    bWS.Range(BS_Result_Range).Value = dstRow - 5
End Sub

'---------------------------------------------------------------------
Function initColData() As Boolean
'---------------------------------------------------------------------
    initColData = True
    CS_ID_Col = getCol(Worksheets(CS_SheetName), "会員番号", initColData)
    CS_MailAddress1_Col = getCol(Worksheets(CS_SheetName), "メール", initColData)
    CS_MailAddress2_Col = getCol(Worksheets(CS_SheetName), "携帯メール", initColData)
    CS_BirthMonth_Col = getCol(Worksheets(CS_SheetName), "誕生月", initColData)
    CS_DM_Deny_Col = getCol(Worksheets(CS_SheetName), "DM", initColData)
    
    VS_ID_Col = getCol(Worksheets(VS_SheetName), "会員番号", initColData)
    VS_Date_Col = getCol(Worksheets(VS_SheetName), "来店日", initColData)
    VS_Price_Col = getCol(Worksheets(VS_SheetName), "売上", initColData)
End Function


'---------------------------------------------------------------------
Function getCol(ws As Worksheet, title$, ByRef errorFlag As Boolean) As String
'---------------------------------------------------------------------
' タイトルから、行情報を取得
'---------------------------------------------------------------------
    Dim i%
    For i = 1 To 255
        If ws.Cells(1, i).Value = "" Then Exit For
        If ws.Cells(1, i).Value = title Then
            getCol = Chr(Asc("A") + i - 1)
            Exit Function
        End If
    Next
    MsgBox "タイトル行[" & title & "]が見つかりません"
    errorFlag = False
End Function

'---------------------------------------------------------------------
Function doesCome(id$, baseDate As Date, searchYear%) As Boolean
'---------------------------------------------------------------------
' 規定年(searchYear)内に来店しているかの確認
'---------------------------------------------------------------------
    Dim vWS As Worksheet
    Set vWS = Worksheets(VS_SheetName)
    
    doesCome = False
    Dim lastRow&
    lastRow = vWS.Range(VS_ID_Col & Rows.count).End(xlUp).Row

    Dim startDate As Date
    startDate = DateSerial(Year(baseDate) - searchYear, Month(baseDate), Day(baseDate))

    Dim i&
    For i = 2 To lastRow
        If vWS.Cells(i, VS_ID_Col).Value = id Then
            If vWS.Cells(i, VS_Date_Col) <= baseDate And vWS.Cells(i, VS_Date_Col) >= startDate Then
                doesCome = True
                Exit Function
            End If
        End If
    Next
End Function

'---------------------------------------------------------------------
Function doesBuy(id, baseDate, searchYear, basePrice) As Boolean
'---------------------------------------------------------------------
' 規定年(searchYear)内に規定額(basePrice)以上購入しているかの確認
'---------------------------------------------------------------------
    Dim vWS As Worksheet
    Set vWS = Worksheets(VS_SheetName)
    
    doesBuy = False
    Dim lastRow&
    lastRow = vWS.Range(VS_ID_Col & Rows.count).End(xlUp).Row
    
    Dim startDate As Date
    startDate = DateSerial(Year(baseDate) - searchYear, Month(baseDate), Day(baseDate))
    
    Dim sumPrice&, i&
    sumPrice = 0
    For i = 2 To lastRow
        If vWS.Cells(i, VS_ID_Col).Value = id Then
            If vWS.Cells(i, VS_Date_Col) <= baseDate And vWS.Cells(i, VS_Date_Col) >= startDate Then
                sumPrice = sumPrice + vWS.Cells(i, VS_Price_Col).Value
                If sumPrice >= basePrice Then
                    doesBuy = True
                    Exit Function
                End If
            End If
        End If
    Next
End Function

  • id:icta
    このマクロを利用するのはエクセルの知識がほとんどない販売スタッフです。
    そのため極力簡単なステップで該当する顧客を抽出したいと思います。
    お知恵とお力をお借りできれば幸いです。
    仕様で何かご不明な点ありましたらお知らせください。


    ■マクロの実行結果

    基準日 2008/6/1
    誕生月 7
    人数 1
    連番 会員番号 旧会員番号 会員資格 名前 フリガナ 郵便番号 住所 電話番号 メール 携帯メール 誕生年 誕生月 誕生日 登録日 修正日 DM
    2 T00583 583 仮 村上 ムラカミ 180-XXXX 東京都XXXX 090XXXX aaa@bbb.com 1973 7 11 2005/12/2 2008/5/20


    ■マクロの仕様

    ○概要
    ※「誕生日DM」シートに基準日と誕生月を入力。
    ※マクロを実行すると以下のルールで該当者を抽出していく。
    ・「顧客名簿」シートの"誕生月"列より入力した誕生月に該当する顧客の会員番号を抽出。
    ・「顧客名簿」シートの"DM"列が空白になっている顧客の会員番号を抽出。"DM"列に値が入力されている顧客はDM拒否者。
    ・「来店記録」シートの"来店日"列を基準日から1年間遡り、上記の会員番号が「来店記録」シートに存在する会員番号を抽出。
    ・「来店記録」シートの"売上"列を基準日から3年間遡り、上記の会員番号が「来店記録」シートに存在するか調べ、存在するものは"売上"列を順に足していく。売上の合計が2万円以上のものだけを抽出。
    ※「顧客名簿」シートから該当する会員番号の行を丸ごと「誕生日DM」シートに転記。
    ※「誕生日DM」シートの”人数”セルの右横に該当者数を表示

    ○詳細
    ※「来店記録」シートは3万行超、「顧客名簿」は1万行超である
    ※「来店記録」シート、「顧客名簿」シート、「誕生日DM」シートは3つとも「顧客管理.xls」ブック内にある。
    ※「来店記録」シート、「顧客名簿」シートにはタイトル行が必ず1行目に存在する。
    ※サンプルデータはいくつかのデータ列を省略。そのため「顧客名簿」シート○番目の列と「来店記録」シート×番目の列を同一の列として比較することはできない。タイトル行を列名で検索し該当する列名が存在した列を比較して抽出をする。
    ※「誕生日DM」シートの1列1行目に基準日、その下に誕生月、その下に人数のセル、その下に顧客名簿と同じタイトル行、その下に該当する顧客が存在する。タイトル行は「誕生日DM」シートに入力済み。

    ■サンプルデータ

    ○「顧客名簿」シート/顧客の個人情報、誕生日を記載
    連番 会員番号 旧会員番号 会員資格 名前 フリガナ 郵便番号 住所 電話番号 メール 携帯メール 誕生年 誕生月 誕生日 登録日 修正日 DM
    2 T00583 583 仮 村上 ムラカミ 180-XXXX 東京都XXXX 090XXXX aaa@bbb.com 1973 7 11 2005/12/2 2008/5/20
    5 C90008 90008 吉住 ヨシズミ 569-XXXX 大阪府XXXX 090XXXX ddd@eee.com ddd@softbank.com 1973 8 17 2005/12/2 2008/5/20
    7 C90001 90001 甲斐 カイ 860-XXXX 熊本県XXXX 096XXXX fff@ggg.com fff@ezweb.com 1974 7 9 2005/12/5 2008/5/20
    8 T00495 495 正 尾崎 オザキ 111-XXXX 福岡県XXXX 012XXXX ozaki@yutaka.jp 1969 7 19 2005/12/30 2008/5/25 ×

    ○「来店記録」シート/顧客の購入履歴を記載
    連番 店舗 会員番号 旧会員番号 会員資格 名前 フリガナ 来店日 担当 売上
    80 渋谷 C90001 90001 甲斐 カイ 2005/3/10 田中 20000
    100 渋谷 T00583 583 仮 村上 ムラカミ 2005/6/10 田中 30000
    1000 渋谷 C90008 90008 吉住 ヨシズミ 2007/7/12 田中 20000
    2000 新宿 T00495 495 正 尾崎 オザキ 2007/8/1 田中 40000
    10000 渋谷 C90001 90001 甲斐 カイ 2007/10/10 田中 8000
    20000 新宿 T00583 583 仮 村上 ムラカミ 2008/5/13 鈴木 2000
    30000 新宿 C00042 42 正 竹下 タケシタ 2008/6/5 鈴木 5000

    ○「誕生日DM」シート/抽出した顧客のシート
    基準日 2008/6/1
    誕生月 7
    人数 1
    連番 会員番号 旧会員番号 会員資格 名前 フリガナ 郵便番号 住所 電話番号 メール 携帯メール 誕生年 誕生月 誕生日 登録日 修正日 DM
    2 T00583 583 仮 村上 ムラカミ 180-XXXX 東京都XXXX 090XXXX aaa@bbb.com 1973 7 11 2005/12/2 2008/5/20


    ■実際の運用
    ・「誕生日DM」シートにて基準日2008/6/1、誕生月7を入力して実行。
    ・「顧客名簿」シートにて”誕生月”列が7である村上、甲斐、尾崎の会員番号を抽出。
    ・「顧客名簿」シートにて”DM”列が空白でない尾崎を除外し、村上、甲斐の会員番号を抽出。
    ・「来店記録」シートにて基準日20008/6/1から1年間遡って(連番20000行~連番1000行)、"会員番号"列から村上、甲斐の会員番号が存在するか調べる。村上、甲斐の会員番号が存在するので基準日より1年以内に購入していることになる。
    ・「来店記録」シートにて基準日20008/6/1から3年間遡って(連番20000行~連番100行)、"会員番号"列から村上、甲斐の会員番号が存在するか調べ、存在すれば"売上"列を順に足していく。3年以内の合計は村上32000円、甲斐8000円。2万円未満の甲斐を除外し、村上の会員番号を抽出。
    ・「顧客名簿」シートにて村上の会員番号の行位置を調べ、行を丸ごとコピー。
    ・「誕生日DM」シートのタイトル行以下に、村上の行をペースト。
    ・「誕生日DM」シートの人数セルの右横に「1」を入れる。
  • id:arhbwastrh
    エクセルシートにサンプルデータを入れて、そこに吹き出し等で解説をつけたものをアップしてもらったほうがわかりやすくて回答を作りやすいですよ。
  • id:taknt
    基準日20008/6/1からって範囲が広いなって突っ込みは さておいて
    基準日から一年前ってことは、基準日の年を -1 にして 日付は +1したものでいいのかな?

    条件さえ 「顧客名簿」シートに入れたら、「顧客名簿」シートのフィルタだけで できるな。
  • id:icta
    > Mookさん
    早々のご回答ありがとうございます。
    早速試してみたところ、途中までは該当する顧客の行が次々と表示されます。
    しかししばらくした後に「型が一致しません」とエラーが出て、▼次の行が黄色で表示されます。

    sumPrice = sumPrice + vWS.Cells(i, VS_Price_Col).Value

    来店記録が3万行超のためInteger→Longにする必要があるのかと思い、3万行以下にして試してみましたが結果は同じでした。
    原因がよくわからないのでお手すきの時に一度チェックしてみていただけませんでしょうか?
    よろしくお願いいたします。
  • id:Mook
    エラーが出てきたときに、sumPrice, i はどうなっていますか?
    このときの「来店記録」シートの i 行のデータが数値でないためのエラーだと思いますが、
    実際のデータはどうなっているでしょうか。

    なお変数宣言の変数末尾の「&」は、ロング型です。
  • id:Mook
    上記のことを確認するために
    If IsNumeric( vWS.Cells(i, VS_Price_Col).Value ) Then
    sumPrice = sumPrice + vWS.Cells(i, VS_Price_Col).Value
    End If
    のように変えてみてどうでしょうか。
  • id:icta
    > Mookさん
    > 上記のことを確認するために
    変更したらうまく行きました。

    > エラーが出てきたときに、sumPrice, i はどうなっていますか?
    エラーが出たとき、sumprice=0、i=31373となっています。
    売上の書式に間違いがあるかもしれないと見直してみたら、注文がキャンセルになったときに"-"を入れていることに気が付きました。
    "売上"列にある値は数値のほかは空白と"-"だけですので恐らく原因はこれだと思われます。
    仕様を作る時によくデータを見直すべきでした。
    教えていただいた変更箇所で問題なく動作していますのでこれにて質問を締め切りますが、もし何らかの変更が必要な時はコメント欄にお知らせいただいてもよろしいでしょうか?

    これまでこの抽出作業に数日をかけていましたが、このマクロによってわずか数十分で抽出作業が済むようになりました。
    しかもこんなに短いコードでこの作業をさせることができることに驚きです。
    本当にありがとうございました。
    また次の機会もよろしくお願いいたします。
  • id:taknt
    >このマクロによってわずか数十分で抽出作業が済むようになりました。

    別にマクロがすごいわけではなく、プログラムとはそういうもの。

    エクセルの知識がないスタッフなら エクセルにこだわる必要もない。

    >注文がキャンセルになったときに"-"を入れていることに気が付きました。

    キャンセルのときは、"-"を入れるってのは 誰の指示なんだろうねぇ。
    普通なら キャンセルフラグでも 持たせるだろうけど。

    毎回いろんな質問で業務内容が よくわかっておもしろいです。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません