人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

●質問者: icta
●カテゴリ:コンピュータ
✍キーワード:DM エクセル コメント コード データ
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● Mook
●1000ポイント ベストアンサー

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


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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ