エクセルのマクロの質問です。来店客の購入履歴を「来店記録」というファイルに記録しています。

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

回答の条件
  • 1人5回まで
  • 登録:2008/06/08 19:56:10
  • 終了:2008/06/11 21:56:30

ベストアンサー

id:SALINGER No.4

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/11 17:12:10

ポイント1000pt

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

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

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

その他の回答(3件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/08 22:44:13

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

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

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

開いたときに、反映させるとしたら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
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/09 19:54:27

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

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

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
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/09 21:40:07

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
id:SALINGER No.4

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/11 17:12:10ここでベストアンサー

ポイント1000pt

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

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

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
  • id:icta
    このマクロを利用するのはエクセルの知識がほとんどない販売スタッフです。
    そのため極力簡単なステップで該当するデータを作成したいと思います。
    お知恵とお力をお借りできれば幸いです。
    仕様で何かご不明な点ありましたらお知らせください。

    この質問はhttp://q.hatena.ne.jp/1208090467の派生質問です。
    仕様の変更は▼次の3点です。
    ○「来店記録」を開いた状態で「お得意様」を開くと常に最新の情報が「お得意様」に載っているようにする。
     変更→「売上順」シートに開始日と終了日を入力後、マクロを実行。※「売上金額順」シートから名前変更。
    ○「来店記録」シート内のすべての顧客を「売上順」シートに表示。
     変更→上位○名で区切る。○は任意で入力。
    ○「売上順」シートには名前、売上金額のみ。
     変更→「売上順」シートには順位、名前、売上、回数、会員番号・・・の順番に記載。会員番号・・・以下は「顧客名簿」シートから該当する会員番号の行を1列目(連番)を除き最終列まで記載する。最終列はマクロ内で変数saisyuretuを設定する。

    これ以外の仕様は同じです。
    念のため仕様を記載しておきます。


    ■マクロの実行結果

    ○「売上順」シート

    開始日 2008/5/1
    終了日 2008/5/31
    上位 5
    順位 売上 回数 会員番号 旧会員番号 会員資格 名前 フリガナ 郵便番号 住所 電話番号 メール 携帯メール
    1 30000 2 T01187 1187 正 大森 オオモリ 569-XXXX 大阪府XXXX 090XXXX ddd@eee.com ddd@softbank.com
    2 20000 1 C01303 1303 正 深沢 フカサワ 111-XXXX 福岡県XXXX 012XXXX eee@hhh.jp
    3 18000 3 C01346 1346 正 大塚 オオツカ 111-XXXX 横浜市XXXX 080XXXX ggg@iiii.jp
    4 17000 3 T01583 1583 仮 村上 ムラカミ 180-XXXX 東京都XXXX 090XXXX aaa@bbb.com
    5 10000 1 C01213 1213 正 松下 マツシタ 860-XXXX 熊本県XXXX 096XXXX fff@ggg.com fff@ezweb.com


    ■マクロの仕様

    ○概要
    ※「売上順」シートに開始日、終了日、上位を入力。
    ※マクロを実行と以下のように計算する。
    ・「来店記録」シートの"会員番号"列を開始日から終了日まで1行づつ進む。
    ・会員番号別の合計売上と合計回数を出す。会員番号ごとに"売上"列の値を足し、1行ごとに1件とカウント。ただし値が「-」ハイフン、空白は売上、回数に含めない。
    ・合計売上順に会員番号を並び替える。
    ・「売上順」シートの"上位"セルに記載された数値まで、順位、売上、回数、会員番号を表示する。
    ・「顧客名簿」シートの最終列をマクロ内に変数(saisyuretu)で設定できるようにしておく。現在はsaisyuretu=19
    ・「売上順」シートの"会員番号"列の値に対応する会員番号を"顧客名簿"シートから見つけ、2列~saisyuretu列までを「売上順」シートに表示する。1列目は連番のため除外。
    ※マクロを終了する。

    ○詳細
    ※バージョンはEXCEL2003。
    ※「来店記録」シートは3万行超である。
    ※「来店記録」シート、「顧客名簿」シート、「売上順」シートは3つとも「顧客管理.xls」ブック内にある。
    ※「来店記録」シート、「顧客名簿」シートはタイトル行が1行目に存在する。
    ※サンプルデータはいくつかのデータ列を省略。そのため「来店記録」シート3番目の列が"会員番号"として定まってはいない。タイトル行を"会員番号"で検索し該当する列名をが存在した時、その列位置を変数に保存する。
    ※「売上順」シートの1列1行目に開始日、その下に終了日、その下に上位のセル、その下にタイトル行、その下に該当する売上順が存在する。
    ※タイトル行は「売上順」シートに入力済み。開始日、終了日、上位の入力は各々のセルの右横隣セルに入力する。
    ※"売上"列に「-」(ハイフン)が入っているものは返品、キャンセルのため売上、回数に含まない。


    ■サンプルデータ(タブ区切り)

    ○「来店記録」シート/顧客の購入履歴を記載
    連番 店舗 会員番号 旧会員番号 会員資格 名前 フリガナ 来店日 担当 売上
    30506 渋谷 T01187 1187 正 大森 オオモリ 2008/4/28 佐藤 5000
    30505 渋谷 T01583 1583 仮 村上 ムラカミ 2008/5/3 田中 15000
    30507 通販 C01213 1213 正 松下 マツシタ 2008/5/11 -
    30508 渋谷 C01346 1346 正 大塚 オオツカ 2008/5/12 高橋 4000
    30509 新宿 C01303 1303 正 深沢 フカサワ 2008/5/15 佐藤 20000
    30510 新宿 T01583 1583 仮 村上 ムラカミ 2008/5/16 佐藤 10000
    30511 新宿 T01187 1187 正 大森 オオモリ 2008/5/17 鈴木 20000
    30512 新宿 C01346 1346 正 大塚 オオツカ 2008/5/18 鈴木 10000
    30513 通販 C01213 1213 正 松下 マツシタ 2008/5/19 10000
    30514 渋谷 C01346 1346 正 大塚 オオツカ 2008/5/20 小島 4000
    30515 渋谷 T01583 1583 仮 村上 ムラカミ 2008/5/21 高橋 7000
    30516 渋谷 T01187 1187 正 大森 オオモリ 2008/5/22 鈴木 10000

    ○「顧客名簿」シート/顧客情報を記載
    連番 会員番号 旧会員番号 会員資格 名前 フリガナ 郵便番号 住所 電話番号 メール 携帯メール
    2 T01583 1583 仮 村上 ムラカミ 180-XXXX 東京都XXXX 090XXXX aaa@bbb.com
    5 T01187 1187 正 大森 オオモリ 569-XXXX 大阪府XXXX 090XXXX ddd@eee.com ddd@softbank.com
    7 C01213 1213 正 松下 マツシタ 860-XXXX 熊本県XXXX 096XXXX fff@ggg.com fff@ezweb.com
    8 C01303 1303 正 深沢 フカサワ 111-XXXX 福岡県XXXX 012XXXX eee@hhh.jp
    10 C01346 1346 正 大塚 オオツカ 111-XXXX 横浜市XXXX 080XXXX ggg@iiii.jp

    ○「売上順」シート/顧客を開始日~終了日の間で売上順に並べる。
    開始日 2008/5/1
    終了日 2008/5/31
    上位 5
    順位 売上 回数 会員番号 旧会員番号 会員資格 名前 フリガナ 郵便番号 住所 電話番号 メール 携帯メール
    1 30000 2 T01187 1187 正 大森 オオモリ 569-XXXX 大阪府XXXX 090XXXX ddd@eee.com ddd@softbank.com
    2 20000 1 C01303 1303 正 深沢 フカサワ 111-XXXX 福岡県XXXX 012XXXX eee@hhh.jp
    3 18000 3 C01346 1346 正 大塚 オオツカ 111-XXXX 横浜市XXXX 080XXXX ggg@iiii.jp
    4 17000 3 T01583 1583 仮 村上 ムラカミ 180-XXXX 東京都XXXX 090XXXX aaa@bbb.com
    5 10000 1 C01213 1213 正 松下 マツシタ 860-XXXX 熊本県XXXX 096XXXX fff@ggg.com fff@ezweb.com


    ■実際の運用
    ※「売上順」シートに開始日「2008/5/1」、終了日「2008/5/31」、上位「5」を入力。
    ※マクロ実行。
    ※「来店記録」シートのタイトル行から会員番号、来店日、売上の位置を確かめ、列位置をそれぞれ変数に入れる。
    ※「来店記録」シートにて"来店日"列が開始日と終了日の条件にあてはまる範囲(連番30505行~連番30516行)を1行づつ進み、会員番号別に合計売上と合計回数を記録する。
    ※「来店記録」シートの"売上"列がハイフンになっている30507行は合計売上、合計回数に含めない。
    ・「売上順」シートの"上位"セルに記載された数値まで、順位、売上、回数、会員番号を表示する。
    ・「売上順」シートの"会員番号"列の値に対応する会員番号を"顧客名簿"シートから見つけ、2列~saisyuretu列までを「売上順」シートに表示する。
    ※マクロ終了。
  • id:taknt
    >※「来店記録」シートは3万行超である。

    エクセルの1シートで管理しやすい件数は 65536件まで。
    つまり、来店記録が倍以上になると 件数を減らすか別のシートにするかもしくは DBにするか
    考えないといけない。
    まだまだ先の話だと思うかもしれないが、早いうちに移行しておけば
    これから追加する機能に影響がないはずだ。
    機能が増えれば増えるほど、移行に対する手間は増える。

    データベースは そもそも管理するためのものなので、質問にあるような使い方に
    一番適しているものである。


  • id:icta
    > SALINGERさん
    早々のご回答ありがとうございました。
    ほぼ期待どおりの動作を確認いたしました。
    スピードも大変早く、これなら必要なデータをすぐに取り出すことができそうです。
    ただ数点だけ思いがけない動作をいたしました。
    この原因は仕様のときの説明不足にあります。

    ○"会員番号"列の値が空白、「不明」だった場合
    作成されたデータを見て気が付いたのですが、「来店記録」シートの"会員番号"列が空白または「不明」となっている場合がありました。
    これは会員番号がわからなかったりしたときの対応です。
    先によくチェックしておくべきでした。
    大変申し訳ありませんが、「来店記録」シートの"会員番号"列の値が空白または「不明」のものは、合計売上、合計回数の計算に含めないようにしていただくことは可能でしょうか?

    ○「顧客名簿」シートから該当する上位者の行をすべて転記する
    ▼仕様のこの部分がうまく働かず、「顧客名簿」シートの携帯メール以降のデータが転記されません。
    ・「顧客名簿」シートの最終列をマクロ内に変数(saisyuretu)で設定できるようにしておく。現在はsaisyuretu=19
    ・「売上順」シートの"会員番号"列の値に対応する会員番号を"顧客名簿"シートから見つけ、2列~saisyuretu列までを「売上順」シートに表示する。1列目は連番のため除外。
    サンプルデータでは見やすさを考え▼以下のようにしたのですが、本当は列数がもっとあります。
    順位 売上 回数 会員番号 旧会員番号 会員資格 名前 フリガナ 郵便番号 住所 電話番号 メール 携帯メール
    本来のデータは携帯メールの後に▼以下のデータが続きます。
    誕生年 誕生月 誕生日 登録日 修正日 DM 備考 転記元
    列数が増えてもすべてを表示できるようにするためsaisyuretu=19とし、数字の変更だけですべてを表示できるように考えたのですがエクセルにとってはあまり良い方法ではなかったでしょうか?
    なおタイトル行は1列目から最終列まですべてのセルに列名が存在しています。

    > 「来店記録」を開いた状態で「お得意様」を開くと常に最新の情報が「お得意様」に載っているようにする。
    > 「お得意様」の仕様がよくわからなかったので、その部分は作っていません。

    この部分は最初の仕様が上の行だったのですが、変更して下の行になったということです。説明不足で申し訳ありませんでした。

     ○「来店記録」を開いた状態で「お得意様」を開くと常に最新の情報が「お得意様」に載っているようにする。
      変更→「売上順」シートに開始日と終了日を入力後、マクロを実行。※「売上金額順」シートから名前変更。

    従って製作していただいたとおりで問題ありません。

    それでは何度もお手数をおかけして申し訳ありませんが、お時間許す時にチェックしていただければ幸いです。
  • id:icta
    > SALINGERさん
    今気が付いたのですが、会員番号と名前がすべて一致していませんでした。
    実際の会員番号を見ると売上の多い顧客の会員番号なので、計算はうまく行っているようです。
    「顧客名簿」シートから会員番号で該当する顧客を探す時にうまく行っていないようです。
    お手すきの時にお確かめいただければ幸いです。


  • id:SALINGER
    なんとなく、不具合の原因がわかりかけてきました。
    まず、列の仕様を勘違いしていたこと。
    会員番号が顧客名簿に無い場合の処理。
    になるんじゃないかと思います。
  • id:SALINGER
    最後の方のjが一つiでした
  • id:icta
    > SALINGERさん
    早々のご回答ありがとうございました。
    1点を除いて希望通りの完璧な動作を確認できました。

    新たにお願いをした仕様の空白については表示されなくなったのですが、会員番号に”不明”も文字が入っていた場合にデータに残っているようです。

     「来店記録」シートの"会員番号"列の値が空白または「不明」のものは、
     合計売上、合計回数の計算に含めないようにしていただくことは可能でしょうか?

    何度もお手数をおかけして申し訳ありませんがお手すきのときにチェックしていただければ幸いです。
  • id:icta
    > SALINGERさん

    早々のご回答ありがとうございました。
    お返事が遅くなりまして申し訳ありません。
    新しく作成していただいた(3)の回答を試したのですが、なぜか▼次のようにマクロの処理が(2)よりも長い時間がかかります。
        1ヶ月 1年間 
    (2) 20秒  8分
    (3) 8分  1時間でも終了せず

    また上のコメントで記載したように”不明”の文字列がいまのところまだ売上に含まれて計算されています。
    原因がよくわからないためお時間あるときにチェックしてみていただいてもよろしいでしょうか?
    お手数をおかけしますがよろしくお願いいたします。
  • id:SALINGER
    試しに5万件の顧客名簿と来店記録を作って実行してみたところかなり重いでした。
    ネストを考え直してみないといけないようですね。
    売上げ順で検索するときは過去よりも最近の日付を入力することが多いでしょうか?
    最近の日付ならば、今まで古い顧客から検索していたのを新しい顧客(下の行)から検索することで
    かなりスピードアップできるからです。
  • id:icta
    > SALINGERさん

    > 売上げ順で検索するときは過去よりも最近の日付を入力することが多いでしょうか?
    はい、いちばんよく使うのは本日の日付より1年間遡るというケースが多いです。
    過去1年間の売上が10万を超えた会員に特別会員の昇格を促すためです。
    このマクロはこの目的のために作成を依頼しました。
    1年より前のデータは調べることもありますが、上記よりもずっと少ないです。
    逆転の発想でスピードアップできるというのはおもしろいですね。
    それではお手数をおかけしますがよろしくお願いいたします。
  • id:SALINGER
    改良して2の回答よりも論理的に2倍以上早くしました。
    いろいろ実験してみると、それでも処理速度が遅い場合がありました。
    大雑把に速度は、
    「顧客名簿の行数」×「日付が該当する来店記録」
    となります。(上位の人数はそんなに関係ありません。)
    自分のパソコンで
    50000×1000の場合8秒程でしたが、
    50000×3000だと50秒程もかかりました。
    それで、日付の期間を開きすぎて設定するとどうしても処理に時間がかかってしまいます。
    >"不明”の文字列がいまのところまだ売上に含まれて計算されています。
    この部分の原因が未だにわからないので考えて見ます。
  • id:icta
    > SALINGERさん

    >>"不明”の文字列がいまのところまだ売上に含まれて計算されています。
    >この部分の原因が未だにわからないので考えて見ます。

    とのことなのですが(2)、(3)ともに”不明”という文字列が存在していません。
    ”会員番号”列に”不明”の文字が含まれる場合は、売上に含めないというフローではなくて、
    ”会員番号”列は英数字の場合に売上に含める、それ以外は売上に含めないという判定なのでしょうか?
    ”不明”という文字列が見出せなかったのでちょっと気になりました。

    時間がかかるのは仕方ないとあきらめています。
    以前は人力でやっていたので1日でも終わらない作業でした。
    処理に30分かかったとしてもそれに比べれば早いものです。
  • id:SALINGER
    更なる改良を加えました。
    50000×1000 4秒
    50000×3000 10秒
    50000×10000 37秒
    なんとか実用的になってきたと思います。
  • id:SALINGER
    会員番号が顧客名簿にない場合は含めないという処理になっています。
  • id:icta
    > SALINGERさん

    早々のご回答ありがとうございました。
    完全に期待通りの動作を確認できました。
    同じ1年分のデータで処理したところ前回8分→今回1分となりました。
    計算方法の違いでこんなにも差が出るとは驚きです。
    このマクロで売上増を目指したいと思います。
    本当にありがとうございました。

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

トラックバック

  • あいまいな仕様には、苦労する。 question:1212922568 これもすべてスタッフが無能?なせい・・・ ではない。 うまくシステム化されていないのが原因だ。 仕様が漏れていたということも考え
「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

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

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