http://q.hatena.ne.jp/1212850896
現在は抽出した順に並んでいますが、これを”会員資格”列で並び替えたいと思います。並び替えルールは昇順です。
一度解決した質問ですが仕様の変更のため新たな質問として投稿いたします。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
一応全体を掲載しますが、おそらくスペルミスだと思います。
私の例がsortReult(sが抜けていた)ので、そのせいではないでしょうか。
失礼しました。
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 sortResult End Sub '--------------------------------------------------------------------- Sub sortResult() '--------------------------------------------------------------------- Dim cl As String Dim isExist As Boolean isExist = True cl = getCol(Worksheets(CS_SheetName), "会員資格", isExist) If isExist = False Then Exit Sub Dim lastRow As Long With Worksheets(BS_SheetName) lastRow = .Range("A" & Rows.Count).End(xlUp).Row .Range("A5:Z" & lastRow).Sort Key1:=Range(cl & 5), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal End With 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
以前回答したマクロに以下の処理を追加し、ListUpDM にこれを呼び出す処理を追加するようにしてみました。
いかがでしょうか。
Sub ListUpDM() : : : sortReult End Sub Sub sortResult() Dim cl As String Dim isExist As Boolean isExist = True cl = getCol(Worksheets(CS_SheetName), "会員資格", isExist) If isExist = False Then Exit Sub Dim lastRow As Long With Worksheets(BS_SheetName) lastRow = .Range("A" & Rows.Count).End(xlUp).Row .Range("A5:Z" & lastRow).Sort Key1:=Range(cl & 5), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal End With End Sub
> Mookさん
早々のご回答ありがとうございました。
早速試してみたのですが以下のエラーが表示されます。
コンパイルエラー;
Sub または Functonが定義されていません
このエラー恐らく私のコピー&ペースの単純な勘違いだと思われます。
前回のマクロを省略せず動作する完全な形のマクロでご回答いただいてもよろしいでしょうか?
よろしくお願いいたします。
一応全体を掲載しますが、おそらくスペルミスだと思います。
私の例がsortReult(sが抜けていた)ので、そのせいではないでしょうか。
失礼しました。
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 sortResult End Sub '--------------------------------------------------------------------- Sub sortResult() '--------------------------------------------------------------------- Dim cl As String Dim isExist As Boolean isExist = True cl = getCol(Worksheets(CS_SheetName), "会員資格", isExist) If isExist = False Then Exit Sub Dim lastRow As Long With Worksheets(BS_SheetName) lastRow = .Range("A" & Rows.Count).End(xlUp).Row .Range("A5:Z" & lastRow).Sort Key1:=Range(cl & 5), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal End With 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
> Mookさん
早々のご回答ありがとうございました。
完全に期待通りの動作を確認できました。
並び替えによって作業がまたひとつ簡単になりました。
本当にありがとうございました。
> Mookさん
早々のご回答ありがとうございました。
完全に期待通りの動作を確認できました。
並び替えによって作業がまたひとつ簡単になりました。
本当にありがとうございました。