エクセルのマクロの質問です。次のマクロははてなで回答者の方々に作成していただいたマクロです。

http://q.hatena.ne.jp/1212850896
現在は抽出した順に並んでいますが、これを”会員資格”列で並び替えたいと思います。並び替えルールは昇順です。
一度解決した質問ですが仕様の変更のため新たな質問として投稿いたします。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。

回答の条件
  • 1人5回まで
  • 登録:2008/06/11 02:53:01
  • 終了:2008/06/11 21:58:47

ベストアンサー

id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912008/06/11 17:25:50

ポイント500pt

一応全体を掲載しますが、おそらくスペルミスだと思います。


私の例が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
id:icta

> Mookさん

早々のご回答ありがとうございました。

完全に期待通りの動作を確認できました。

並び替えによって作業がまたひとつ簡単になりました。

本当にありがとうございました。

2008/06/11 21:58:22

その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912008/06/11 10:18:19

以前回答したマクロに以下の処理を追加し、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
id:icta

> Mookさん

早々のご回答ありがとうございました。

早速試してみたのですが以下のエラーが表示されます。

 コンパイルエラー;

 Sub または Functonが定義されていません

 

このエラー恐らく私のコピー&ペースの単純な勘違いだと思われます。

前回のマクロを省略せず動作する完全な形のマクロでご回答いただいてもよろしいでしょうか?

よろしくお願いいたします。 

2008/06/11 14:54:52
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912008/06/11 17:25:50ここでベストアンサー

ポイント500pt

一応全体を掲載しますが、おそらくスペルミスだと思います。


私の例が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
id:icta

> Mookさん

早々のご回答ありがとうございました。

完全に期待通りの動作を確認できました。

並び替えによって作業がまたひとつ簡単になりました。

本当にありがとうございました。

2008/06/11 21:58:22
  • id:taknt
    これなら簡単。

    会員資格に並べ替えるプログラムを 最後に追加してあげればいいだけだ。
  • id:Mook
    無事に動作したようでなによりです。

    実際の動作に影響しないかもしれませんが、追加した部分の
    .Range("A5:Z" & lastRow).Sort Key1:=Range(cl & 5), Order1:=xlAscending, Header:=xlNo, _

    .Range("A5:Z" & lastRow).Sort Key1:=.Range(cl & 5), Order1:=xlAscending, Header:=xlNo, _
    のようにおいて変更してください(Range のまえのピリオドです)。

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

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

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

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