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

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

●質問者: icta
●カテゴリ:コンピュータ
✍キーワード:はてな エクセル コード ポイント マクロ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● Mook
●0ポイント

以前回答したマクロに以下の処理を追加し、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が定義されていません

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

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

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


2 ● Mook
●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
◎質問者からの返答

> Mookさん

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

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

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

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

関連質問


●質問をもっと探す●



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