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

エクセルのマクロの質問です。来店客の購入履歴を「来店記録」というファイルに記録しています。
開始日と終了日を設定し、「来店記録」を元に顧客ごとの売上金額を多→少の順番に並び替え、どの顧客がもっとも貢献度が高いかを調べたいと思います。
貢献度の高い顧客にはそれに見合った質の高いサービスを提供し、顧客満足度を高めたいと考えています。
なお、この質問はhttp://q.hatena.ne.jp/1208090467の派生質問です。
仕様に変更があったため新たな質問として投稿します。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
※文字制限のためサンプルデータ、仕様の詳細はこの下にある「この質問・回答へのコメント」に記載いたします。


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

▽最新の回答へ

1 ● SALINGER
●0ポイント

>「来店記録」を開いた状態で「お得意様」を開くと常に最新の情報が「お得意様」に載っているようにする。

「お得意様」の仕様がよくわからなかったので、その部分は作っていません。

最初の方にある「お得意様」というのが後の方の「売上順」になるのかな。

開いたときに、反映させるとしたらWorksheet_Activate()イベントから呼び出すようにするといいです。


Sub UriageJyun()
 Application.ScreenUpdating = False
 Dim RMidasiName(3) As String
 Dim RMidasiCol(3) As Integer
 Dim KMidasiName(10) As String
 Dim KMidasiCol(10) As Integer
 Dim saisyuretu As Long
 Dim Usaisyuretu As Long
 Dim Ksaisyuretu As Long
 Dim StartDay As Date
 Dim EndDay As Date
 Dim jyouiNum As Integer
 
  '作業用変数
 Dim i As Integer
 Dim j As Long
 Dim k As Integer
 Dim r As Range
 Dim f As Boolean

 Dim wr As Worksheet  '来店記録シート
 Dim wu As Worksheet  '売上順シート
 Dim wk As Worksheet  '顧客名簿シート

 Set wr = Worksheets("来店記録")
 Set wu = Worksheets("売上順")
 Set wk = Worksheets("顧客名簿")

 RMidasiName(0) = "会員番号"
 RMidasiName(1) = "来店日"
 RMidasiName(2) = "売上"

 KMidasiName(0) = "会員番号"
 KMidasiName(1) = "旧会員番号"
 KMidasiName(2) = "会員資格"
 KMidasiName(3) = "名前"
 KMidasiName(4) = "フリガナ"
 KMidasiName(5) = "郵便番号"
 KMidasiName(6) = "住所"
 KMidasiName(7) = "電話番号"
 KMidasiName(8) = "メール"
 KMidasiName(9) = "携帯メール"
 
 Usaisyuretu = 5
 
  '来店記録の列の位置を取得
 For i = 0 To 2
 Set r = wr.Rows(1).Find(what:=RMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に" & RMidasiName(i) & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 RMidasiCol(i) = r.Column
 Next i
 
  '顧客名簿の列の位置を取得
 For i = 0 To 9
 Set r = wk.Rows(1).Find(what:=KMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "顧客名簿に" & KMidasiName(i) & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 KMidasiCol(i) = r.Column
 Next i
 
  '開始日と終了日のチェック
 If IsDate(wu.Range("B1").Value) And wu.Range("B1").Value <> "" Then
 StartDay = wu.Range("B1").Value
 Else
 MsgBox "開始日に日付を入力してください"
 Exit Sub
 End If
 If IsDate(wu.Range("B2").Value) And wu.Range("B2").Value <> "" Then
 EndDay = wu.Range("B2").Value
 Else
 MsgBox "終了日に日付を入力してください"
 Exit Sub
 End If
 
  '上位のチェック
 If IsNumeric(wu.Range("B3").Value) And wu.Range("B3").Value <> "" Then
 jyouiNum = wu.Range("B3").Value
 Else
 MsgBox "上位に数字を入力してください"
 Exit Sub
 End If
 
  '売上順のシートのクリア
 wu.Rows("5:65536").ClearContents
 
  '来店記録の最終行の取得
 saisyuretu = wr.Cells(65536, RMidasiCol(0)).End(xlUp).Row
 For i = 2 To saisyuretu
 If IsDate(wr.Cells(i, RMidasiCol(1)).Value) Then
 If wr.Cells(i, RMidasiCol(1)).Value >= StartDay And _
 wr.Cells(i, RMidasiCol(1)).Value <= EndDay And _
 wr.Cells(i, RMidasiCol(2)).Value <> "-" And _
 wr.Cells(i, RMidasiCol(2)).Value <> "" Then
 f = False
 j = 5
 While j < Usaisyuretu And f = False
 If wu.Cells(j, 4).Value = wr.Cells(i, RMidasiCol(0)).Value Then
 wu.Cells(j, 2).Value = wu.Cells(j, 2).Value + wr.Cells(i, RMidasiCol(2)).Value
 wu.Cells(j, 3).Value = wu.Cells(j, 3).Value + 1
 f = True
 End If
 j = j + 1
 Wend
 If f = False Then
 wu.Cells(Usaisyuretu, 4).Value = wr.Cells(i, RMidasiCol(0)).Value
 wu.Cells(Usaisyuretu, 2).Value = wr.Cells(i, RMidasiCol(2)).Value
 wu.Cells(Usaisyuretu, 3).Value = 1
 Usaisyuretu = Usaisyuretu + 1
 End If
 End If
 End If
 Next i
 
  'ソート
 wu.Range("A4:M" & Usaisyuretu - 1).Sort Key1:=Range("B5"), Order1:=xlDescending, Header:=xlGuess, _
 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
 :=xlPinYin, DataOption1:=xlSortNormal
 
  '順位の表示
 For i = 1 To jyouiNum
 wu.Cells(i + 4, 1).Value = i
 Next i
 
  '上位以下をクリア
 wu.Rows(jyouiNum + 5 & ":65536").ClearContents
 
  '顧客名簿から顧客情報を転記
 Ksaisyuretu = wk.Cells(65536, KMidasiCol(0)).End(xlUp).Row
 For i = 5 To jyouiNum + 4
 For j = 2 To Ksaisyuretu
 If wk.Cells(j, KMidasiCol(0)).Value = wu.Cells(i, 4).Value Then
 For k = 1 To 9
 wu.Cells(i, k + 4).Value = wk.Cells(i, KMidasiCol(k)).Value
 Next k
 Exit For
 End If
 Next j
 Next i
 
 Application.ScreenUpdating = True
End Sub

2 ● SALINGER
●0ポイント

ほとんど変更して、ほとんど列の取得のコードになりました。

自分の環境ではこれで問題なさそうですが、たくさんのデータの元で動かしてみておかしな点があれば教えてください。

Sub UriageJyun()
 Application.ScreenUpdating = False
 Dim Rsaisyugyou As Long
 Dim Usaisyugyou As Long
 Dim Ksaisyugyou As Long
 Dim StartDay As Date
 Dim EndDay As Date
 Dim jyouiNum As Integer
 
  '作業用変数
 Dim i As Integer
 Dim j As Long
 Dim k As Integer
 Dim r As Range
 Dim f As Boolean

 Dim wr As Worksheet  '来店記録シート
 Dim wu As Worksheet  '売上順シート
 Dim wk As Worksheet  '顧客名簿シート
 
 Const saisyuretu As Integer = 19  '顧客名簿の最終列
 
 Dim KMidasiName(saisyuretu) As String
 Dim KMidasiCol(saisyuretu) As Integer
 Dim UMidasiCol(saisyuretu + 2) As Integer
 Dim RMidasiCol(3) As Integer

 Set wr = Worksheets("来店記録")
 Set wu = Worksheets("売上順")
 Set wk = Worksheets("顧客名簿")

  '顧客名簿の列名の取得
 Set r = wk.Rows(1).Find(what:="会員番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "顧客名簿に会員番号の列名は存在しません。"
 Exit Sub
 End If
 KMidasiCol(0) = r.Column
 KMidasiName(0) = "会員番号"
 
 j = 1
 For i = 1 To saisyuretu
 If wk.Cells(1, i).Value <> "会員番号" And wk.Cells(1, i).Value <> "連番" Then
 KMidasiCol(j) = i
 KMidasiName(j) = wk.Cells(1, i).Value
 j = j + 1
 End If
 Next i
 
  '売上順の列の位置を取得
 Set r = wu.Rows(4).Find(what:="会員番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に会員番号の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(0) = r.Column
 
 Set r = wu.Rows(4).Find(what:="順位", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に順位の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(1) = r.Column
 
 Set r = wu.Rows(4).Find(what:="売上", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に売上の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(2) = r.Column
 
 Set r = wu.Rows(4).Find(what:="回数", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に回数の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(3) = r.Column

 For i = 1 To saisyuretu - 2
 Set r = wu.Rows(4).Find(what:=KMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に" & KMidasiName(i) & "の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(i + 3) = r.Column
 Next i
 
  '来店記録の列の位置を取得
 Set r = wr.Rows(1).Find(what:="会員番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に会員番号の列名は存在しません。"
 Exit Sub
 End If
 RMidasiCol(0) = r.Column
 
 Set r = wr.Rows(1).Find(what:="来店日", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に来店日の列名は存在しません。"
 Exit Sub
 End If
 RMidasiCol(1) = r.Column
 
 Set r = wr.Rows(1).Find(what:="売上", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に売上の列名は存在しません。"
 Exit Sub
 End If
 RMidasiCol(2) = r.Column
 
  '開始日と終了日のチェック
 If IsDate(wu.Range("B1").Value) And wu.Range("B1").Value <> "" Then
 StartDay = wu.Range("B1").Value
 Else
 MsgBox "開始日に日付を入力してください"
 Exit Sub
 End If
 If IsDate(wu.Range("B2").Value) And wu.Range("B2").Value <> "" Then
 EndDay = wu.Range("B2").Value
 Else
 MsgBox "終了日に日付を入力してください"
 Exit Sub
 End If
 
  '上位のチェック
 If IsNumeric(wu.Range("B3").Value) And wu.Range("B3").Value <> "" Then
 jyouiNum = wu.Range("B3").Value
 Else
 MsgBox "上位に数字を入力してください"
 Exit Sub
 End If
 
  '売上順のシートのクリア
 wu.Rows("5:65536").ClearContents
 
  '来店記録の最終行の取得
 Rsaisyugyou = wr.Cells(65536, RMidasiCol(0)).End(xlUp).Row
 Usaisyugyou = 5
 For i = 2 To Rsaisyugyou
 If IsDate(wr.Cells(i, RMidasiCol(1)).Value) Then
 If wr.Cells(i, RMidasiCol(0)).Value <> "" And _
 wr.Cells(i, RMidasiCol(1)).Value >= StartDay And _
 wr.Cells(i, RMidasiCol(1)).Value <= EndDay And _
 wr.Cells(i, RMidasiCol(2)).Value <> "-" And _
 wr.Cells(i, RMidasiCol(2)).Value <> "" Then
 f = False
 j = 5
 While j < Usaisyugyou And f = False
 If wu.Cells(j, UMidasiCol(0)).Value = wr.Cells(i, RMidasiCol(0)).Value Then
 wu.Cells(j, UMidasiCol(2)).Value = _
 wu.Cells(j, UMidasiCol(2)).Value + wr.Cells(i, RMidasiCol(2)).Value
 wu.Cells(j, UMidasiCol(3)).Value = wu.Cells(j, UMidasiCol(3)).Value + 1
 f = True
 End If
 j = j + 1
 Wend
 If f = False Then
 wu.Cells(Usaisyugyou, UMidasiCol(0)).Value = wr.Cells(i, RMidasiCol(0)).Value
 wu.Cells(Usaisyugyou, UMidasiCol(2)).Value = wr.Cells(i, RMidasiCol(2)).Value
 wu.Cells(Usaisyugyou, UMidasiCol(3)).Value = 1
 Usaisyugyou = Usaisyugyou + 1
 End If
 End If
 End If
 Next i
 
  'ソート
 wu.Range("A4:IV" & Usaisyugyou - 1).Sort Key1:=Cells(5, UMidasiCol(2)), _
 Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
 Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal

  '順位の表示
 For i = 1 To jyouiNum
 wu.Cells(i + 4, UMidasiCol(1)).Value = i
 Next i

  '上位以下をクリア
 wu.Rows(jyouiNum + 5 & ":65536").ClearContents

  '顧客名簿から顧客情報を転記
 Ksaisyugyou = wk.Cells(65536, KMidasiCol(0)).End(xlUp).Row
 For i = 5 To jyouiNum + 4
 For j = 2 To Ksaisyugyou
 If wk.Cells(j, KMidasiCol(0)).Value = wu.Cells(i, UMidasiCol(0)).Value Then
 For k = 1 To saisyuretu - 2
 wu.Cells(i, UMidasiCol(k + 3)).Value = wk.Cells(j, KMidasiCol(k)).Value
 Next k
 Exit For
 End If
 Next j
 Next i
 
 Application.ScreenUpdating = True
End Sub

3 ● SALINGER
●0ポイント
Sub UriageJyun()
 Application.ScreenUpdating = False
 Dim Rsaisyugyou As Long
 Dim Usaisyugyou As Long
 Dim Ksaisyugyou As Long
 Dim StartDay As Date
 Dim EndDay As Date
 Dim jyouiNum As Integer
 
  '作業用変数
 Dim i As Integer
 Dim j As Long
 Dim k As Integer
 Dim r As Range
 Dim f As Boolean
 Dim f2 As Boolean

 Dim wr As Worksheet  '来店記録シート
 Dim wu As Worksheet  '売上順シート
 Dim wk As Worksheet  '顧客名簿シート
 
 Const saisyuretu As Integer = 19  '顧客名簿の最終列
 
 Dim KMidasiName(saisyuretu) As String
 Dim KMidasiCol(saisyuretu) As Integer
 Dim UMidasiCol(saisyuretu + 2) As Integer
 Dim RMidasiCol(3) As Integer

 Set wr = Worksheets("来店記録")
 Set wu = Worksheets("売上順")
 Set wk = Worksheets("顧客名簿")

  '顧客名簿の列名の取得
 Set r = wk.Rows(1).Find(what:="会員番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "顧客名簿に会員番号の列名は存在しません。"
 Exit Sub
 End If
 KMidasiCol(0) = r.Column
 KMidasiName(0) = "会員番号"
 
 j = 1
 For i = 1 To saisyuretu
 If wk.Cells(1, i).Value <> "会員番号" And wk.Cells(1, i).Value <> "連番" Then
 KMidasiCol(j) = i
 KMidasiName(j) = wk.Cells(1, i).Value
 j = j + 1
 End If
 Next i
 
  '売上順の列の位置を取得
 Set r = wu.Rows(4).Find(what:="会員番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に会員番号の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(0) = r.Column
 
 Set r = wu.Rows(4).Find(what:="順位", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に順位の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(1) = r.Column
 
 Set r = wu.Rows(4).Find(what:="売上", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に売上の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(2) = r.Column
 
 Set r = wu.Rows(4).Find(what:="回数", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に回数の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(3) = r.Column

 For i = 1 To saisyuretu - 2
 Set r = wu.Rows(4).Find(what:=KMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に" & KMidasiName(i) & "の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(i + 3) = r.Column
 Next i
 
  '来店記録の列の位置を取得
 Set r = wr.Rows(1).Find(what:="会員番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に会員番号の列名は存在しません。"
 Exit Sub
 End If
 RMidasiCol(0) = r.Column
 
 Set r = wr.Rows(1).Find(what:="来店日", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に来店日の列名は存在しません。"
 Exit Sub
 End If
 RMidasiCol(1) = r.Column
 
 Set r = wr.Rows(1).Find(what:="売上", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に売上の列名は存在しません。"
 Exit Sub
 End If
 RMidasiCol(2) = r.Column
 
  '開始日と終了日のチェック
 If IsDate(wu.Range("B1").Value) And wu.Range("B1").Value <> "" Then
 StartDay = wu.Range("B1").Value
 Else
 MsgBox "開始日に日付を入力してください"
 Exit Sub
 End If
 If IsDate(wu.Range("B2").Value) And wu.Range("B2").Value <> "" Then
 EndDay = wu.Range("B2").Value
 Else
 MsgBox "終了日に日付を入力してください"
 Exit Sub
 End If
 
  '上位のチェック
 If IsNumeric(wu.Range("B3").Value) And wu.Range("B3").Value <> "" Then
 jyouiNum = wu.Range("B3").Value
 Else
 MsgBox "上位に数字を入力してください"
 Exit Sub
 End If
 
  '売上順のシートのクリア
 wu.Rows("5:65536").ClearContents
 
 Ksaisyugyou = wk.Cells(65536, KMidasiCol(0)).End(xlUp).Row
 
  '来店記録の最終行の取得
 Rsaisyugyou = wr.Cells(65536, RMidasiCol(0)).End(xlUp).Row
 Usaisyugyou = 5
 For i = 2 To Rsaisyugyou
 If IsDate(wr.Cells(i, RMidasiCol(1)).Value) Then
 If wr.Cells(i, RMidasiCol(0)).Value <> "" And _
 wr.Cells(i, RMidasiCol(1)).Value >= StartDay And _
 wr.Cells(i, RMidasiCol(1)).Value <= EndDay And _
 wr.Cells(i, RMidasiCol(2)).Value <> "-" And _
 wr.Cells(i, RMidasiCol(2)).Value <> "" Then
 
  '顧客名簿に会員番号があるかをチェック
 f2 = False
 For j = 2 To Ksaisyugyou
 If wk.Cells(j, KMidasiCol(0)).Value = wr.Cells(i, RMidasiCol(0)).Value Then
 f2 = True
 Exit For
 End If
 Next j
 
 If f2 Then
 f = False
 j = 5
 While j < Usaisyugyou And f = False
 If wu.Cells(j, UMidasiCol(0)).Value = wr.Cells(i, RMidasiCol(0)).Value Then
 wu.Cells(j, UMidasiCol(2)).Value = _
 wu.Cells(j, UMidasiCol(2)).Value + wr.Cells(i, RMidasiCol(2)).Value
 wu.Cells(j, UMidasiCol(3)).Value = wu.Cells(j, UMidasiCol(3)).Value + 1
 f = True
 End If
 j = j + 1
 Wend
 If f = False Then
 wu.Cells(Usaisyugyou, UMidasiCol(0)).Value = wr.Cells(i, RMidasiCol(0)).Value
 wu.Cells(Usaisyugyou, UMidasiCol(2)).Value = wr.Cells(i, RMidasiCol(2)).Value
 wu.Cells(Usaisyugyou, UMidasiCol(3)).Value = 1
 Usaisyugyou = Usaisyugyou + 1
 End If
 End If
 End If
 End If
 Next i
 
  'ソート
 wu.Range("A4:IV" & Usaisyugyou - 1).Sort Key1:=Cells(5, UMidasiCol(2)), _
 Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
 Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal

  '順位の表示
 For i = 1 To jyouiNum
 wu.Cells(i + 4, UMidasiCol(1)).Value = i
 Next i

  '上位以下をクリア
 wu.Rows(jyouiNum + 5 & ":65536").ClearContents

  '顧客名簿から顧客情報を転記
 For i = 5 To jyouiNum + 4
 For j = 2 To Ksaisyugyou
 If wk.Cells(j, KMidasiCol(0)).Value = wu.Cells(i, UMidasiCol(0)).Value Then
 For k = 1 To saisyuretu - 2
 wu.Cells(i, UMidasiCol(k + 3)).Value = wk.Cells(j, KMidasiCol(k)).Value
 Next k
 Exit For
 End If
 Next j
 Next i
 
 Application.ScreenUpdating = True
End Sub

4 ● SALINGER
●1000ポイント ベストアンサー

自分のテストでは会員番号に不明な文字がある場合は含まれないのですが。

まだ、売上に含まれて計算されている場合は教えてください。

Sub UriageJyun()
 Application.ScreenUpdating = False
 Dim Rsaisyugyou As Long
 Dim Usaisyugyou As Long
 Dim Ksaisyugyou As Long
 Dim StartDay As Date
 Dim EndDay As Date
 Dim jyouiNum As Integer
 Dim myRow As Long
 
  '作業用変数
 Dim i As Long
 Dim j As Long
 Dim k As Integer
 Dim r As Range
 Dim f As Boolean
 Dim f2 As Boolean

 Dim wr As Worksheet  '来店記録シート
 Dim wu As Worksheet  '売上順シート
 Dim wk As Worksheet  '顧客名簿シート
 
 Const saisyuretu As Integer = 19  '顧客名簿の最終列
 
 Dim KMidasiName(saisyuretu) As String
 Dim KMidasiCol(saisyuretu) As Integer
 Dim UMidasiCol(saisyuretu + 2) As Integer
 Dim RMidasiCol(3) As Integer

 Set wr = Worksheets("来店記録")
 Set wu = Worksheets("売上順")
 Set wk = Worksheets("顧客名簿")

  '顧客名簿の列名の取得
 Set r = wk.Rows(1).Find(what:="会員番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "顧客名簿に会員番号の列名は存在しません。"
 Exit Sub
 End If
 KMidasiCol(0) = r.Column
 KMidasiName(0) = "会員番号"
 
 j = 1
 For i = 1 To saisyuretu
 If wk.Cells(1, i).Value <> "会員番号" And wk.Cells(1, i).Value <> "連番" Then
 KMidasiCol(j) = i
 KMidasiName(j) = wk.Cells(1, i).Value
 j = j + 1
 End If
 Next i
 
  '売上順の列の位置を取得
 Set r = wu.Rows(4).Find(what:="会員番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に会員番号の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(0) = r.Column
 
 Set r = wu.Rows(4).Find(what:="順位", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に順位の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(1) = r.Column
 
 Set r = wu.Rows(4).Find(what:="売上", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に売上の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(2) = r.Column
 
 Set r = wu.Rows(4).Find(what:="回数", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に回数の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(3) = r.Column

 For i = 1 To saisyuretu - 2
 Set r = wu.Rows(4).Find(what:=KMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "売上順に" & KMidasiName(i) & "の列名は存在しません。"
 Exit Sub
 End If
 UMidasiCol(i + 3) = r.Column
 Next i
 
  '来店記録の列の位置を取得
 Set r = wr.Rows(1).Find(what:="会員番号", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に会員番号の列名は存在しません。"
 Exit Sub
 End If
 RMidasiCol(0) = r.Column
 
 Set r = wr.Rows(1).Find(what:="来店日", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に来店日の列名は存在しません。"
 Exit Sub
 End If
 RMidasiCol(1) = r.Column
 
 Set r = wr.Rows(1).Find(what:="売上", lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に売上の列名は存在しません。"
 Exit Sub
 End If
 RMidasiCol(2) = r.Column
 
  '開始日と終了日のチェック
 If IsDate(wu.Range("B1").Value) And wu.Range("B1").Value <> "" Then
 StartDay = wu.Range("B1").Value
 Else
 MsgBox "開始日に日付を入力してください"
 Exit Sub
 End If
 If IsDate(wu.Range("B2").Value) And wu.Range("B2").Value <> "" Then
 EndDay = wu.Range("B2").Value
 Else
 MsgBox "終了日に日付を入力してください"
 Exit Sub
 End If
 
  '上位のチェック
 If IsNumeric(wu.Range("B3").Value) And wu.Range("B3").Value <> "" Then
 jyouiNum = wu.Range("B3").Value
 Else
 MsgBox "上位に数字を入力してください"
 Exit Sub
 End If
 
  '売上順のシートのクリア
 wu.Rows("5:65536").ClearContents
 
 Ksaisyugyou = wk.Cells(65536, KMidasiCol(0)).End(xlUp).Row
 
  '来店記録の最終行の取得
 Rsaisyugyou = wr.Cells(65536, RMidasiCol(0)).End(xlUp).Row
 Usaisyugyou = 5
 For i = 2 To Rsaisyugyou
 If IsDate(wr.Cells(i, RMidasiCol(1)).Value) Then
 If wr.Cells(i, RMidasiCol(0)).Value <> "" And _
 wr.Cells(i, RMidasiCol(1)).Value >= StartDay And _
 wr.Cells(i, RMidasiCol(1)).Value <= EndDay And _
 wr.Cells(i, RMidasiCol(2)).Value <> "-" And _
 wr.Cells(i, RMidasiCol(2)).Value <> "" Then
 
  '顧客名簿に会員番号があるかをチェック
 f2 = False
 Set r = wk.Columns(KMidasiCol(0)).Find(what:=wr.Cells(i, RMidasiCol(0)).Value, lookat:=xlWhole)
 If r Is Nothing Then
 f2 = False
 Else
 wu.Cells(Usaisyugyou, UMidasiCol(4)).Value = r.Row
 f2 = True
 End If
 If f2 Then
 Set r = wu.Columns(UMidasiCol(0)).Find(what:=wr.Cells(i, RMidasiCol(0)).Value, lookat:=xlWhole)
 If r Is Nothing Then
 wu.Cells(Usaisyugyou, UMidasiCol(0)).Value = wr.Cells(i, RMidasiCol(0)).Value
 wu.Cells(Usaisyugyou, UMidasiCol(2)).Value = wr.Cells(i, RMidasiCol(2)).Value
 wu.Cells(Usaisyugyou, UMidasiCol(3)).Value = 1
 Usaisyugyou = Usaisyugyou + 1
 Else
 wu.Cells(r.Row, UMidasiCol(2)).Value = _
 wu.Cells(r.Row, UMidasiCol(2)).Value + wr.Cells(i, RMidasiCol(2)).Value
 wu.Cells(r.Row, UMidasiCol(3)).Value = wu.Cells(r.Row, UMidasiCol(3)).Value + 1
 End If
 End If
 End If
 End If
 Next i
 
  'ソート
 wu.Range("A4:IV" & Usaisyugyou - 1).Sort Key1:=Cells(5, UMidasiCol(2)), _
 Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
 Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal

  '順位の表示
 For i = 1 To jyouiNum
 wu.Cells(i + 4, UMidasiCol(1)).Value = i
 Next i

  '上位以下をクリア
 wu.Rows(jyouiNum + 5 & ":65536").ClearContents
 
 If jyouiNum + 4 > Usaisyugyou - 1 Then
 myRow = Usaisyugyou - 1
 Else
 myRow = jyouiNum + 4
 End If
 
  '顧客名簿から顧客情報を転記
 For i = 5 To myRow
 j = wu.Cells(i, UMidasiCol(4)).Value
 For k = 1 To saisyuretu - 2
 wu.Cells(i, UMidasiCol(k + 3)).Value = wk.Cells(j, KMidasiCol(k)).Value
 Next k
 Next i
 
 Application.ScreenUpdating = True
End Sub
関連質問


●質問をもっと探す●



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