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

購入履歴ごとに担当者を入力しており、担当者別の売上と順位を作成したいと思います。ただしワーストが判ると担当者の士気に影響するので上位○名と表示する人数を指定できるようにしたいと思います。
ピボットテーブルも試したのですが、希望するデータを得られるまでに時間がかかるのでマクロで自動化できればと考えています。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
※文字制限のためサンプルデータ、仕様の詳細はこの下にある「この質問・回答へのコメント」に記載いたします。

回答の条件
  • 1人5回まで
  • 登録:2008/06/08 03:44:31
  • 終了:2008/06/11 21:50:51

回答(5件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912008/06/08 10:31:38

今回は「担当別売上」のシートモジュールに張り付けて実行してみてください

(シートタブを右クリックして「コードを表示」で表示される部分)


Option Explicit

'---------------------------------------------------------------------
Sub MakeTopN()
'---------------------------------------------------------------------
    Dim srcWS As Worksheet
    Set srcWS = Worksheets("来店記録")
        
    Dim thisWS As Worksheet
    Set thisWS = ActiveSheet
        
    If Worksheets(Worksheets.Count).Name = "TEMP" Then
        Application.DisplayAlerts = False
        Worksheets("TEMP").Delete
        Application.DisplayAlerts = True
    End If
    
    Rows("4:1000").Clear
    
    srcWS.Copy After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = "TEMP"
    Dim tmpWS As Worksheet
    Set tmpWS = Worksheets("TEMP")
    
    Dim lastRow&, sLastRow&, titleCol$, i&
    Dim isFind As Boolean
    isFind = True
    
    With tmpWS
        titleCol = getCol(tmpWS, "来店日", isFind)
        If Not isFind Then Exit Sub
        lastRow = .Range(titleCol & Rows.Count).End(xlUp).Row
        
        .Columns(titleCol).AutoFilter Field:=1, Criteria1:="<" & Range("B1").Value _
        , Operator:=xlOr, Criteria2:=">" & Range("B2").Value
        .Range("A1").CurrentRegion.Select
        Selection.EntireRow.Delete
        
        srcWS.Rows(1).Copy
        .Rows(1).Insert shift:=xlDown
        
        titleCol = getCol(tmpWS, "担当", isFind)
        If Not isFind Then Exit Sub
        
        .Columns(titleCol).AutoFilter Field:=1, Criteria1:="="
        .Range("A1").CurrentRegion.Select
        Selection.EntireRow.Delete
    
        srcWS.Rows(1).Copy
        .Rows(1).Insert shift:=xlDown
        
        sLastRow = .Range(titleCol & Rows.Count).End(xlUp).Row
        
        .Columns(titleCol).AutoFilter
        .Columns(titleCol).AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=.Range("AA1"), Unique:=True
        lastRow = .Range("AA" & Rows.Count).End(xlUp).Row
    
        .Range("AA1:AD1") = Array("担当", "売上合計", "売上割合", " 売上件数")
        .Range("AB2").Formula = "=SUMIF($I$2:$J$" & sLastRow & ",AA2,$J$2:$J$" & sLastRow & ")"
        .Range("AC2").Formula = "=AB2/SUM($J$2:$J$" & sLastRow & ")"
        .Range("AC2").NumberFormatLocal = "0.0%"
        .Range("AD2").Formula = "=COUNTIF($I$2:$I$" & sLastRow & ",AA2)"
        .Range("AB2:AD2").Copy Destination:=.Range("AB3:AD" & lastRow)
        Application.CutCopyMode = False
    
        .Range("AA1:AD" & lastRow).Sort key1:=.Range("AC2:AC" & lastRow), order1:=xlDescending, DataOption1:=xlSortNormal, _
            Header:=xlYes, Orientation:=xlTopToBottom
    
        .Range("AA1:AD" & 1 + Range("B3").Value).Copy
        Range("B4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=False
        Range("A4").Value = "順位"
        For i = 1 To Range("B3")
            Cells(4 + i, "A") = i
        Next
    End With
    If Worksheets(Worksheets.Count).Name = "TEMP" Then
        Application.DisplayAlerts = False
        Worksheets("TEMP").Delete
        Application.DisplayAlerts = True
    End If

    thisWS.Activate
End Sub

'---------------------------------------------------------------------
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
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912008/06/08 13:14:10

仕様でタイトル列を見て、という部分が計算式の個所で未対応でしたので、修正しました。

Option Explicit

'---------------------------------------------------------------------
Sub MakeTopN()
'---------------------------------------------------------------------
    
    Rows("4:1000").Clear
    
    Dim srcWS As Worksheet
    Set srcWS = Worksheets("来店記録")
    
    Dim thisWS As Worksheet
    Set thisWS = ActiveSheet
    
    If Worksheets(Worksheets.Count).Name = "TEMP" Then
        Application.DisplayAlerts = False
        Worksheets("TEMP").Delete
        Application.DisplayAlerts = True
    End If
        
    srcWS.Copy After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = "TEMP"
    Dim tmpWS As Worksheet
    Set tmpWS = Worksheets("TEMP")

    checkData srcWS, tmpWS

    If Worksheets(Worksheets.Count).Name = "TEMP" Then
        Application.DisplayAlerts = False
        Worksheets("TEMP").Delete
        Application.DisplayAlerts = True
    End If

    thisWS.Activate
    
End Sub

'---------------------------------------------------------------------
Sub checkData(srcWS As Worksheet, tmpWS As Worksheet)
'---------------------------------------------------------------------
    Dim lastRow&, sLastRow&, titleCol$, i&
    Dim isFind As Boolean
    isFind = True
    
    With tmpWS
        titleCol = getCol(tmpWS, "来店日", isFind)
        If Not isFind Then Exit Sub
        lastRow = .Range(titleCol & Rows.Count).End(xlUp).Row
        
        .Columns(titleCol).AutoFilter Field:=1, Criteria1:="<" & Range("B1").Value _
        , Operator:=xlOr, Criteria2:=">" & Range("B2").Value
        .Range("A1").CurrentRegion.Select
        Selection.EntireRow.Delete
        
        srcWS.Rows(1).Copy
        .Rows(1).Insert shift:=xlDown
        
        titleCol = getCol(tmpWS, "担当", isFind)
        If Not isFind Then Exit Sub
        
        .Columns(titleCol).AutoFilter Field:=1, Criteria1:="="
        .Range("A1").CurrentRegion.Select
        Selection.EntireRow.Delete
    
        srcWS.Rows(1).Copy
        .Rows(1).Insert shift:=xlDown
        
        sLastRow = .Range(titleCol & Rows.Count).End(xlUp).Row
        
        .Columns(titleCol).AutoFilter
        .Columns(titleCol).AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=.Range("AA1"), Unique:=True
        lastRow = .Range("AA" & Rows.Count).End(xlUp).Row
        
        If lastRow = 1 Then
            MsgBox "条件に一致する売り上げデータがありません。"
            Exit Sub
        End If
    
        Dim tCol$, pCol$
        tCol = getCol(tmpWS, "担当", isFind)
        pCol = getCol(tmpWS, "売上", isFind)
        If Not isFind Then Exit Sub
        
        .Range("AA1:AD1") = Array("担当", "売上合計", "売上割合", " 売上件数")
        .Range("AB2").Formula = "=SUMIF($" & tCol & "$2:$" & pCol & "$" & sLastRow & ",AA2," _
            & "$" & pCol & "$2:$" & pCol & "$" & sLastRow & ")"
        .Range("AC2").Formula = "=AB2/SUM($" & pCol & "$2:$" & pCol & "$" & sLastRow & ")"
        .Range("AC2").NumberFormatLocal = "0.0%"
        .Range("AD2").Formula = "=COUNTIF($" & tCol & "$2:$" & tCol & "$" & sLastRow & ",AA2)"
        .Range("AB2:AD2").Copy Destination:=.Range("AB3:AD" & lastRow)
        Application.CutCopyMode = False
    
        .Range("AA1:AD" & lastRow).Sort key1:=.Range("AC2:AC" & lastRow), order1:=xlDescending, DataOption1:=xlSortNormal, _
            Header:=xlYes, Orientation:=xlTopToBottom
    
        .Range("AA1:AD" & 1 + Range("B3").Value).Copy
        Range("B4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=False
        Range("A4").Value = "順位"
        For i = 1 To Range("B3")
            Cells(4 + i, "A") = i
        Next
    End With
End Sub

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

Mook回答回数1312ベストアンサー獲得回数3912008/06/08 21:47:04

2番目の回答の checkData を下記に差し替えてみてください。

Sub checkData(srcWS As Worksheet, tmpWS As Worksheet)
    Dim lastRow&, sLastRow&, titleCol$, i&
    Dim isFind As Boolean
    isFind = True
    
    With tmpWS
    '------  対象日付の絞り込み
        titleCol = getCol(tmpWS, "来店日", isFind)
        If Not isFind Then Exit Sub
        lastRow = .Range(titleCol & Rows.Count).End(xlUp).Row
        
        For i = lastRow To 2 Step -1
            If .Cells(i, titleCol) <= Range("B2").Value Then
                Exit For
            End If
        Next
        If i + 1 <= lastRow Then
            .Rows(i + 1 & ":" & lastRow).Delete shift:=xlUp
        End If
        
        lastRow = .Range(titleCol & Rows.Count).End(xlUp).Row
        For i = 2 To lastRow
            If .Cells(i, titleCol) >= Range("B1").Value Then
                Exit For
            End If
        Next
        If i - 1 >= 2 Then
            .Rows("2:" & i - 1).Delete shift:=xlUp
        End If
MsgBox "対象の日付範囲だけ残っていますか?"
        
    '------  担当の絞り込み
        titleCol = getCol(tmpWS, "担当", isFind)
        If Not isFind Then Exit Sub
        
        If .AutoFilterMode = True Then
            .Range("A1").AutoFilter
        End If
        
        .Columns(titleCol).AutoFilter Field:=1, Criteria1:="="
        .Range("A1").CurrentRegion.Select
        Selection.EntireRow.Delete
    
        srcWS.Rows(1).Copy
        .Rows(1).Insert shift:=xlDown
        
        If .AutoFilterMode = True Then
            .Range("A1").AutoFilter
        End If

MsgBox "対象のデータが残っていますか?"
        sLastRow = .Range(titleCol & Rows.Count).End(xlUp).Row
        .Columns(titleCol).AutoFilter
        .Columns(titleCol).AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=.Range("AA1"), Unique:=True
        lastRow = .Range("AA" & Rows.Count).End(xlUp).Row
        
        If lastRow = 1 Then
            MsgBox "条件に一致する売り上げデータがありません。"
            Exit Sub
        End If
    
    '------  担当のリストアップ
        Dim tCol$, pCol$
        tCol = getCol(tmpWS, "担当", isFind)
        pCol = getCol(tmpWS, "売上", isFind)
        If Not isFind Then Exit Sub
        
        .Range("AA1:AD1") = Array("担当", "売上合計", "売上割合", " 売上件数")
    '------  計算式の適用
        .Range("AB2").Formula = "=SUMIF($" & tCol & "$2:$" & pCol & "$" & sLastRow & ",AA2," _
            & "$" & pCol & "$2:$" & pCol & "$" & sLastRow & ")"
        .Range("AC2").Formula = "=AB2/SUM($" & pCol & "$2:$" & pCol & "$" & sLastRow & ")"
        .Range("AC2").NumberFormatLocal = "0.0%"
        .Range("AD2").Formula = "=COUNTIF($" & tCol & "$2:$" & tCol & "$" & sLastRow & ",AA2)"
        .Range("AB2:AD2").Copy Destination:=.Range("AB3:AD" & lastRow)
        Application.CutCopyMode = False
    
        .Range("AA1:AD" & lastRow).Sort key1:=.Range("AC2:AC" & lastRow), order1:=xlDescending, DataOption1:=xlSortNormal, _
            Header:=xlYes, Orientation:=xlTopToBottom
    
    '------  結果の表示
        .Range("AA1:AD" & 1 + Range("B3").Value).Copy
        Range("B4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=False
        Range("A4").Value = "順位"
        For i = 1 To Range("B3")
            Cells(4 + i, "A") = i
        Next
    End With
End Sub

問題なければ、確認用の msgBox を削除ください。

id:Mook No.4

Mook回答回数1312ベストアンサー獲得回数3912008/06/09 21:06:18

コメントいただいた点を反映してみました。

動作と処理速度をご確認いただけるでしょうか。


3万行のデータで処理してみましたが、前回から多少は速くなっていると思います。

(こちらでの実行時間は2~3秒でした)


Option Explicit

Const TMP_WS_NAME = "CTN_TEMP"
Const SRC_WS_NAME = "来店記録"

'---------------------------------------------------------------------
Sub MakeTopN()
'---------------------------------------------------------------------
    Dim thisWS As Worksheet
    Set thisWS = ActiveSheet
    
    thisWS.Unprotect
    Rows("5:1000").Clear   '--- 結果のクリア
    
    Dim srcWS As Worksheet
    Set srcWS = Worksheets(SRC_WS_NAME)
   
'--- 作業シートが残っていたら削除
    Dim tmpWS As Worksheet
    On Error Resume Next
    Set tmpWS = Worksheets(TMP_WS_NAME)
    On Error GoTo 0
    
    If Not tmpWS Is Nothing Then
        Application.DisplayAlerts = False
        Worksheets(TMP_WS_NAME).Delete
        Application.DisplayAlerts = True
    End If
    
'--- 作業シートを作成
    srcWS.Copy After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = TMP_WS_NAME
    Set tmpWS = Worksheets(TMP_WS_NAME)

'--- 処理の実行
    checkData srcWS, tmpWS

'--- 作業シートを削除
    Application.DisplayAlerts = False
    Worksheets(TMP_WS_NAME).Delete
    Application.DisplayAlerts = True

'--- 元のシートをアクティブに変更
    thisWS.Activate
    thisWS.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
End Sub

'---------------------------------------------------------------------
Sub checkData(srcWS As Worksheet, tmpWS As Worksheet)
'---------------------------------------------------------------------
    Dim lastRow&, sLastRow&, titleCol$, i&, sl&, el&
    Dim isFind As Boolean
    isFind = True
    
    With tmpWS
    '------  対象日付の絞り込み
        titleCol = getCol(tmpWS, "来店日", isFind)
        If Not isFind Then Exit Sub
        
        sl = getDateStartLine(tmpWS, titleCol, Range("B1"))
        el = getDateEndLine(tmpWS, titleCol, Range("B2"))
        
        If el < sl Or sl = -1 Or el = -1 Then
            MsgBox "日付の指定範囲が正しくありません"
            Exit Sub
        End If
        
        tmpWS.Rows(sl & ":" & el).Copy Destination:=tmpWS.Range("A2")
        tmpWS.Rows(el - sl + 3 & ":" & Rows.Count).Clear
        
    '------  担当の絞り込み
        titleCol = getCol(tmpWS, "担当", isFind)
        If Not isFind Then Exit Sub
        
        If .AutoFilterMode = True Then
            .Range("A1").AutoFilter
        End If
        
        .Columns(titleCol).AutoFilter Field:=1, Criteria1:="="
        .Range("A1").CurrentRegion.Select
        Selection.EntireRow.Delete
    
        srcWS.Rows(1).Copy
        .Rows(1).Insert shift:=xlDown
        
        If .AutoFilterMode = True Then
            .Range("A1").AutoFilter
        End If

        sLastRow = .Range(titleCol & Rows.Count).End(xlUp).Row
        .Columns(titleCol).AutoFilter
        .Columns(titleCol).AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=.Range("AA1"), Unique:=True
        lastRow = .Range("AA" & Rows.Count).End(xlUp).Row
        
        If lastRow = 1 Then
            MsgBox "条件に一致する売り上げデータがありません。"
            Exit Sub
        End If
    
    '------  担当のリストアップ
        Dim tCol$, pCol$
        tCol = getCol(tmpWS, "担当", isFind)
        pCol = getCol(tmpWS, "売上", isFind)
        If Not isFind Then Exit Sub
        
        .Rows(1).Delete shift:=xlUp
        lastRow = .Range("AA" & Rows.Count).End(xlUp).Row
        
    '------  計算式の適用
        .Range("AB1").Formula = "=SUMIF($" & tCol & "$1:$" & pCol & "$" & sLastRow & ",AA1," _
            & "$" & pCol & "$1:$" & pCol & "$" & sLastRow & ")"
        .Range("AC1").Formula = "=AB1/SUM($" & pCol & "$1:$" & pCol & "$" & sLastRow & ")"
        .Range("AC1").NumberFormatLocal = "0.0%"
        .Range("AD1").Formula = "=COUNTIF($" & tCol & "$1:$" & tCol & "$" & sLastRow & ",AA1)"
        .Range("AB1:AD1").Copy Destination:=.Range("AB2:AD" & lastRow)
        Application.CutCopyMode = False
    
        .Range("AA1:AD" & lastRow).Sort key1:=.Range("AC1:AC" & lastRow), order1:=xlDescending, DataOption1:=xlSortNormal, _
            Header:=xlNo, Orientation:=xlTopToBottom
    
    '------  結果の表示
        .Range("AA1:AD" & Range("B3").Value).Copy
        Range("B5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=False
        Range("A5").Value = "順位"
        For i = 1 To Range("B3")
            Cells(4 + i, "A") = i
        Next
    End With
End Sub

'---------------------------------------------------------------------
Function getDateStartLine(ws As Worksheet, cl$, dd As Date) As Long
'---------------------------------------------------------------------
' 指定ワークシートの対象列から、して日付の先頭行を取得する
'---------------------------------------------------------------------
    Const StepSize = 200
    
    Dim lastRow&, i&, j&, sr&, er&
    lastRow = ws.Range(cl & Rows.Count).End(xlUp).Row
    
    If ws.Cells(2, cl).Value >= dd Then
        getDateStartLine = 2
        Exit Function
    End If
    
    If ws.Cells(lastRow, cl).Value < dd Then
        getDateStartLine = -1
        Exit Function
    End If
    
    For er = 2 To lastRow Step StepSize
        If ws.Cells(er, cl).Value >= dd Then Exit For
    Next

    If er > lastRow Then er = lastRow
    If er - StepSize <= 1 Then
        sr = 2
    Else
        sr = er - StepSize
    End If
    
    For i = er To sr Step -1
        If ws.Cells(i, cl).Value < dd Then
            getDateStartLine = i + 1
            Exit Function
        End If
    Next
    
    getDateStartLine = -1
End Function

'---------------------------------------------------------------------
Function getDateEndLine(ws As Worksheet, cl$, dd As Date) As Long
'---------------------------------------------------------------------
' 指定ワークシートの対象列から、して日付の最終行を取得する
'---------------------------------------------------------------------
    Const StepSize = 200
    
    Dim lastRow&, i&, j&, sr&, er&
    lastRow = ws.Range(cl & Rows.Count).End(xlUp).Row
    
    If ws.Cells(2, cl).Value > dd Then
        getDateEndLine = -1
        Exit Function
    End If
    
    If ws.Cells(lastRow, cl).Value <= dd Then
        getDateEndLine = lastRow
        Exit Function
    End If
    
    For er = 2 To lastRow Step StepSize
        If ws.Cells(er, cl).Value > dd Then Exit For
    Next

    If er > lastRow Then er = lastRow
    If er - StepSize <= 1 Then
        sr = 2
    Else
        sr = er - StepSize
    End If
    
    For i = er To sr Step -1
        If ws.Cells(i, cl).Value <= dd Then
            getDateEndLine = i
            Exit Function
        End If
    Next
    
    getDateEndLine = -1
End Function


'---------------------------------------------------------------------
Function getCol(ws As Worksheet, title$, ByRef errorFlag As Boolean) As String
'---------------------------------------------------------------------
' タイトルから、行情報を取得
'---------------------------------------------------------------------
    Dim i%
    For i = 1 To 27
        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
id:Mook No.5

Mook回答回数1312ベストアンサー獲得回数3912008/06/11 09:48:09

ポイント1500pt

処理が遅い原因がわかりませんが、おまじないを入れてみました。

Option Explicit

Const TMP_WS_NAME = "CTN_TEMP"
Const SRC_WS_NAME = "来店記録"

'---------------------------------------------------------------------
Sub MakeTopN()
'---------------------------------------------------------------------
    Dim thisWS As Worksheet
    Set thisWS = ActiveSheet
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    thisWS.Unprotect
    Rows("5:1000").Clear   '--- 結果のクリア
    
    Dim srcWS As Worksheet
    Set srcWS = Worksheets(SRC_WS_NAME)
   
'--- 作業シートが残っていたら削除
    Dim tmpWS As Worksheet
    On Error Resume Next
    Set tmpWS = Worksheets(TMP_WS_NAME)
    On Error GoTo 0
    
    If Not tmpWS Is Nothing Then
        Application.DisplayAlerts = False
        Worksheets(TMP_WS_NAME).Delete
        Application.DisplayAlerts = True
    End If
    
'--- 作業シートを作成
    srcWS.Copy After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = TMP_WS_NAME
    Set tmpWS = Worksheets(TMP_WS_NAME)

'--- 処理の実行
    checkData srcWS, tmpWS

'--- 作業シートを削除
    Application.DisplayAlerts = False
    Worksheets(TMP_WS_NAME).Delete
    Application.DisplayAlerts = True

'--- 元のシートをアクティブに変更
    thisWS.Activate
    thisWS.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

'---------------------------------------------------------------------
Sub checkData(srcWS As Worksheet, tmpWS As Worksheet)
'---------------------------------------------------------------------
    Dim lastRow&, sLastRow&, titleCol$, i&, sl&, el&
    Dim isFind As Boolean
    isFind = True
    
    With tmpWS
        If .AutoFilterMode = True Then
            .ShowAllData
        End If
    
    '------  対象日付の絞り込み
        titleCol = getCol(tmpWS, "来店日", isFind)
        If Not isFind Then Exit Sub
        
        sl = getDateLine(tmpWS, titleCol, Range("B1"), True)
        el = getDateLine(tmpWS, titleCol, Range("B2"), False)
        If el < sl Or sl = -1 Or el = -1 Then
            MsgBox "日付の指定範囲が正しくありません"
            Exit Sub
        End If
        
        tmpWS.Rows(sl & ":" & el).Copy Destination:=tmpWS.Range("A2")
        tmpWS.Rows(el - sl + 3 & ":" & Rows.Count).Clear
        
    '------  担当の絞り込み
        titleCol = getCol(tmpWS, "担当", isFind)
        If Not isFind Then Exit Sub
        
        .Columns(titleCol).AutoFilter Field:=1, Criteria1:="="
        .Range("A1").CurrentRegion.Select
        Selection.EntireRow.Delete
    
        srcWS.Rows(1).Copy
        .Rows(1).Insert shift:=xlDown
        
        If .AutoFilterMode = True Then
            .ShowAllData
        End If

        sLastRow = .Range(titleCol & Rows.Count).End(xlUp).Row
        .Columns(titleCol).AutoFilter
        .Columns(titleCol).AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=.Range("AA1"), Unique:=True
        lastRow = .Range("AA" & Rows.Count).End(xlUp).Row
        
        If lastRow = 1 Then
            MsgBox "条件に一致する売り上げデータがありません。"
            Exit Sub
        End If
    
    '------  担当のリストアップ
        Dim tCol$, pCol$
        tCol = getCol(tmpWS, "担当", isFind)
        pCol = getCol(tmpWS, "売上", isFind)
        If Not isFind Then Exit Sub
        
        .Rows(1).Delete shift:=xlUp
        lastRow = .Range("AA" & Rows.Count).End(xlUp).Row
        
    '------  計算式の適用
        .Range("AB1").Formula = "=SUMIF($" & tCol & "$1:$" & pCol & "$" & sLastRow & ",AA1," _
            & "$" & pCol & "$1:$" & pCol & "$" & sLastRow & ")"
        .Range("AB1").NumberFormatLocal = "#,##0"
        .Range("AC1").Formula = "=AB1/SUM($" & pCol & "$1:$" & pCol & "$" & sLastRow & ")"
        .Range("AC1").NumberFormatLocal = "0.0%"
        .Range("AD1").Formula = "=COUNTIF($" & tCol & "$1:$" & tCol & "$" & sLastRow & ",AA1)"
        .Range("AE1").Formula = "=IF(AD1>0,AB1/AD1,"""")"
        .Range("AE1").NumberFormatLocal = "#,##0.00"
        
        Application.Calculation = xlCalculationAutomatic
        .Range("AB1:AE1").Copy Destination:=.Range("AB2:AE" & lastRow)
        Application.Calculation = xlCalculationManual
        
        Application.CutCopyMode = False
    
        .Range("AA1:AE" & lastRow).Sort key1:=.Range("AC1:AC" & lastRow), order1:=xlDescending, DataOption1:=xlSortNormal, _
            Header:=xlNo, Orientation:=xlTopToBottom
    
    '------  結果の表示
        .Range("AA1").Resize(Range("B3").Value, 5).Copy
        Range("B5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=False
        Range("A5").Value = "順位"
        For i = 1 To Range("B3")
            Cells(4 + i, "A") = i
        Next
    End With
End Sub

'---------------------------------------------------------------------
Function getDateLine(ws As Worksheet, cl$, dd As Date, Optional toTop As Boolean = True) As Long
'---------------------------------------------------------------------
' 指定ワークシートの対象列から、して日付の先頭行を取得する
'---------------------------------------------------------------------
    
    Dim lastRow&, i&, j&, sr&, er&
    sr = 2
    lastRow = ws.Range(cl & Rows.Count).End(xlUp).Row
    If toTop = True Then
        If ws.Cells(2, cl).Value >= dd Then
            getDateLine = 2
            Exit Function
        End If
        
        If ws.Cells(lastRow, cl).Value < dd Then
            getDateLine = -1
            Exit Function
        End If
    Else
        If ws.Cells(2, cl).Value > dd Then
            getDateLine = -1
            Exit Function
        End If
        
        If ws.Cells(lastRow, cl).Value <= dd Then
            getDateLine = lastRow
            Exit Function
        End If
    End If
    
    er = lastRow
    Do While True
        i = CLng((sr + er) / 2)
        If ws.Cells(i, cl).Value = dd Then Exit Do
        If sr = er Then Exit Do
        If ws.Cells(i, cl).Value > dd Then er = i
        If ws.Cells(i, cl).Value < dd Then sr = i
    Loop
    If toTop = True Then
        Select Case True
            Case ws.Cells(i, cl).Value >= dd
                For j = i To 2 Step -1
                    If ws.Cells(j, cl).Value < dd Then
                        getDateLine = j + 1
                        Exit Function
                    End If
                Next
            Case ws.Cells(i, cl).Value < dd
                For j = i To lastRow
                    If ws.Cells(j, cl).Value >= dd Then
                        getDateLine = j
                        Exit Function
                    End If
                Next
        End Select
    Else
        Select Case True
            Case ws.Cells(i, cl).Value <= dd
                For j = i To lastRow
                    If ws.Cells(j, cl).Value > dd Then
                        getDateLine = j - 1
                        Exit Function
                    End If
                Next
            Case ws.Cells(i, cl).Value > dd
                For j = i To 2 Step -1
                    If ws.Cells(j, cl).Value < dd Then
                        getDateLine = j + 1
                        Exit Function
                    End If
                Next
        End Select
    End If
    getDateLine = -1
End Function

'---------------------------------------------------------------------
Function getCol(ws As Worksheet, title$, ByRef errorFlag As Boolean) As String
'---------------------------------------------------------------------
' タイトルから、行情報を取得
'---------------------------------------------------------------------
    Dim i%
    For i = 1 To 27
        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
  • id:icta
    このマクロを利用するのはエクセルの知識がほとんどない販売スタッフです。
    そのため極力簡単なステップで該当するデータを作成したいと思います。
    お知恵とお力をお借りできれば幸いです。
    仕様で何かご不明な点ありましたらお知らせください。


    ■マクロの実行結果

    開始日 2008/5/1
    終了日 2008/5/31
    上位 3
    順位 担当 売上合計 売上割合 売上件数
    1 鈴木 40000 40% 3
    2 佐藤 30000 30% 2
    3 田中 15000 15% 1

    4 高橋 11000 11% 2
    5 小島 4000 4% 1

    ※上位3に設定したときは1~3まで、上位20に設定したときは1~5までを表示。担当が20名いても期間内で働いていない場合は表示されない。


    ■マクロの仕様

    ○概要
    ※「担当別売上」シートに開始日、終了日、上位を入力。
    ※マクロを実行すると以下のルールで該当者を抽出していく。
    ・「来店記録」シートの"担当"列を開始日から終了日まで1行づつ進み、担当ごとに"売上"列の値を足し、1行ごとに1件とカウントしていく。ただし担当が空白になっている行は担当のない売上なので飛ばす。この行は売上合計にも売上件数にも含めない。
    ・担当別売上の合計を出し、各担当の売上割合を出す。
    ・売上が多い順に並び替える
    ・「担当別売上」シートの"上位"セルに記載された数値までを表示しマクロを終了する。
    ※上位はセルの保護をかけてスタッフにはセルの変更ができないようにする。

    ○詳細
    ※「来店記録」シートは3万行超である
    ※「来店記録」シート、「担当別売上」シートは2つとも「顧客管理.xls」ブック内にある。
    ※「来店記録」シートはタイトル行が1行目に存在する。
    ※サンプルデータはいくつかのデータ列を省略。そのため「来店記録」シート8番目の列が"来店日"として定まってはいない。タイトル行を列名で検索し該当する列名を調査対象とする。
    ※「担当別売上」シートの1列1行目に開始日、その下に終了日、その下に上位のセル、その下にタイトル行、その下に該当する担当別売上順位が存在する。タイトル行は「担当別売上」シートに入力済み。入力は開始日、終了日、上位のセルの右横セルに入力する。


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

    ○「来店記録」シート/顧客の購入履歴を記載
    連番 店舗 会員番号 旧会員番号 会員資格 名前 フリガナ 来店日 担当 売上
    30506 渋谷 T01187 1187 正 大森 オオモリ 2008/4/28 佐藤 5000
    30505 渋谷 T01032 1032 仮 河本 コウモト 2008/5/3 田中 15000
    30507 通販 C01213 1213 正 松下 マツシタ 2008/5/11 9000
    30508 渋谷 C01346 1346 正 大塚 オオツカ 2008/5/12 高橋 4000
    30509 新宿 C01303 1303 正 深沢 フカサワ 2008/5/15 佐藤 20000
    30510 新宿 C01718 1718 正 上坂 ウエサカ 2008/5/16 佐藤 10000
    30511 新宿 T01275 1275 正 森元 モリモト 2008/5/17 鈴木 20000
    30512 新宿 T00024 0024 仮 谷原 タニハラ 2008/5/18 鈴木 10000
    30513 通販 C01078 1078 仮 金沢 カナザワ 2008/5/19 10000
    30514 渋谷 T91224 1224 仮 品川 シナガワ 2008/5/20 小島 4000
    30515 渋谷 T01955 1955 仮 相川 アイカワ 2008/5/21 高橋 7000
    30516 渋谷 C01004 1004 仮 杉山 スギヤマ 2008/5/22 鈴木 10000

    ○担当別売上/担当ごとの売上を昇順で並び替え

    開始日 2008/5/1
    終了日 2008/5/31
    上位 4
    順位 担当 売上合計 売上割合 売上件数
    1 鈴木 40000 40% 3
    2 佐藤 30000 30% 2
    3 田中 15000 15% 1
    4 高橋 11000 11% 2


    ■実際の運用
    ※「担当別売上」シートに開始日「2008/5/1」、終了日「2008/5/31」、上位「4」を入力。
    ※マクロ実行。
    ※「来店記録」シートのタイトル行から会員番号、担当、売上の位置を確かめる。
    ※「来店記録」シートにて"来店日"列を調べ、開始日と終了日の条件にあてはまる範囲(連番30505行~連番30516行)を1行づつ進み、担当別に売上合計と売上件数を作成する。
    ※「来店記録」シートの"担当"列が空白になっている30507と30513は売上合計にも売上件数にも含めない。
    ※担当別に売上割合を計算し、売上合計順に並び替える。
    ※「担当別売上」シートの上位に記載された数字までをタイトル行の下に表示する。
    ※マクロ終了。
  • id:taknt
    売上割合を計算しろといわれても 計算式がないと 計算できないね。
  • id:icta
    > Mookさん
    早々のご回答ありがとうございました。
    早速試してみたのですが「担当別売上」シートには▼以下のような結果が表示されました。
    エラーの表示は今回はありません。

    開始日 2008/4/1
    終了日 2008/5/1
    上位 3
    順位 担当 0 #DIV/0! 0
    1 0 #DIV/0! 0
    2 0 #DIV/0! 0
    3

    もしかしたら先にご回答いただいたものと同じく、売上に"-"が入っているものがマクロに影響を与えているのでしょうか?
    「来店記録」シートの"売上"列には数値と"-"と空白があります。"担当"列には担当の名前と空白があります。"来店日"列は日付順ですべて日付の形式になって日付順に並んでおり、日付の順序が前後することはありません。
    何に問題があるのかさっぱり見当が付かないため何か原因ではないと思われるものがあれば教えてください。
    よろしくお願いいたします。
  • id:Mook
    こちらは EXCEL の標準関数を使用しているので、数値でない部分は加算されませんが、
    現象としては、該当するものがうまく検出できていないようですね。

    下から 20 行くらいの
    Worksheets("TEMP").Delete
    をコメントアウトして、確認してみてください。

    TEMP シートで集計していますが、該当のものがリストアップされているでしょうか。
    こちらシートのAA列からAD列で結果を集計していますので、この部分が期待通りか確認ください。

    ステップ実行(VBE で F8を押しながら実行)をご存じであれば、シートを見ながらこれを
    見ることで、どこが原因かを見つけやすくなります。
  • id:Mook
    計算式の部分で、担当と売上を I列とJ列を想定して書いた部分が残っていましたので、
    これが異なっていると、結果のようになると思います。

    その部分と、そうなった場合のエラー処理を付加したコードを再回答しました。

    これで結果が変わらない場合は、再度コメントください。
  • id:icta
    > TEMP シートで集計していますが、該当のものがリストアップされているでしょうか。
    > こちらシートのAA列からAD列で結果を集計していますので、この部分が期待通りか確認ください。

    試してみました。
    リストアップはされていないようです。

    > その部分と、そうなった場合のエラー処理を付加したコードを再回答しました。
    > ステップ実行(VBE で F8を押しながら実行)をご存じであれば、シートを見ながらこれを
    > 見ることで、どこが原因かを見つけやすくなります。

    最終的に「条件に一致するデータがありません。」というエラー表示が出ます。
    ステップ実行してみたところ、"担当"列が空白行のみをフィルタリングしているのがわかりました。

    ▼この先頭行のときに、「TEMP」シートに「来店記録」シートのすべてが転記されます。
    With tmpWS
    titleCol = getCol(tmpWS, "来店日", isFind)
    If Not isFind Then Exit Sub

    ▼この最終行のときに"連番"列のフィルタが「39539より小さい」OR「39569より大きい」となっています。
    .Columns(titleCol).AutoFilter Field:=1, Criteria1:="<" & Range("B1").Value _
    , Operator:=xlOr, Criteria2:=">" & Range("B2").Value
    .Range("A1").CurrentRegion.Select

    すべての行は39000行以下のですし、これだとすべての行があてはまるのでここに問題があるような気がします。


    ▼上記のすぐ下に以下のコードがあります。この最終行のときに"J"列="担当"列が空白だけのものを選んでいます。
    Selection.EntireRow.Delete

    srcWS.Rows(1).Copy
    .Rows(1).Insert shift:=xlDown

    これが「条件に一致するデータがありません。」というエラー表示につながっていると思います。
    どこに原因があるのかよくわからないためもし他に可能性があるような場所があったら教えてください。
    よろしくお願いします。
  • id:Mook
    処理のフローですが、

    (1)まず来店記録をTEMPシートに丸ごとコピーします。
    (2)次に担当者の空欄の行を削除します(処理をしないため)。
    (3)次にB1以前の日付とB2以降の日付を削除します(対象外のため)。

    この時点で、表示されているデータがないでしょうか。

    これで、対象のデータのみ残るはずですので、これを処理しているのですが、
    B1、B2の日付けはどうなっているでしょうか。
    「39539より小さい」OR「39569より大きい」は行ではなく、日付の値(1900/1/1からの通算日数)
    なので、一応それでよいはずです。

    B1、B2(たぶんこちらはよさそうですね)、来店日はすべて日付型になっていますか?
    ここが文字列型だとうまく動作しません。


    一点気になるのは、
    Selection.EntireRow.Delete
    の実行直後、AutoFilter は解除されるでしょうか?

    Office 2007 ではそのような挙動だったのですが、そうでない場合次の処理の前に AutoFilter を外す処理が必要です。
    その際は上記の後ろ(2か所)に下記を付け加えれば、よいと思います。
      If tmpWS.AutoFilterMode = True Then
        tmpWS.Range("A1").AutoFilter
      End If
  • id:Mook
    ちょっと調べてみたら、AutoFilter での日付のフィルタはいろいろと問題があるようですね。
    お使いの EXCEL のバージョンはいくつでしょうか。

    日付のフィルタのせいだとしたら、処理を変えねばなりません。
    確認ですが、来店記録は2行目以降に日付順に並んでいることを想定して、処理をして
    かまわないでしょうか。
  • id:icta
    > Mookさん

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

    > 「39539より小さい」OR「39569より大きい」は行ではなく、日付の値(1900/1/1からの通算日数)
    > なので、一応それでよいはずです。

    この条件は"来店日"列ではなくて"連番"列で処理が行われています。
    そのため上の条件に当てはまる行は来店記録すべての行となっています。"連番"列で上記の条件にあてはまるのはすべての行となります。
    これが日付の値であるならば"来店日"列で処理を行うのが本来の動作ではないかと思われます。

    > (1)まず来店記録をTEMPシートに丸ごとコピーします。

    丸ごとコピーはされています。

    > (2)次に担当者の空欄の行を削除します(処理をしないため)。

    担当者の空欄の行は削除されていません。反対に空欄の行以外が削除されています。

    > (3)次にB1以前の日付とB2以降の日付を削除します(対象外のため)。

    上で抽出した内容はすべて削除されています。

    > 来店日はすべて日付型になっていますか?

    来店日列はすべて日付型になっています。

    > の実行直後、AutoFilter は解除されるでしょうか?

    解除されています。

    > お使いの EXCEL のバージョンはいくつでしょうか。

    2003です。

    > 来店記録は2行目以降に日付順に並んでいることを想定して、処理をして
    > かまわないでしょうか。

    来店記録は2行目に以降に日付順に並んでいます。新しい日付と古い日付が逆に入ることは他のマクロの動作で不具合が出るため絶対にありません。

    お手数をおかけして申し訳ありませんが、お時間の許す時にチェックしていただければ幸いです。
  • id:Mook
    提示されたサンプルについてですが、こちらでは期待通りに動いているだけに、わけがわからないですね。
    >この条件は"来店日"列ではなくて"連番"列で処理が行われています。
    >そのため上の条件に当てはまる行は来店記録すべての行となっています。"連番"列で上記の条件にあてはまるのはすべての行となります。
    と判断できる状況はどのあたりからでしょうか。

    指定列は、タイトル行の"来店日"を探して処理しているのですが、実際の処理でtitleCol に 来店日の列が入っていないでしょうか。

    データが日付順になっているのでしたら、オートフィルタの処理は、やめて別の処理にしてみます。

    >担当者の空欄の行は削除されていません。反対に空欄の行以外が削除されています。
    との状況は確かでしょうか。
    担当者が空白のものを削除するために、いったん担当者が空白行のみを表示する処理をしています。
    その直後、表示されている行を全部削除しますので、
    Selection.EntireRow.Delete
    それによってこの直後、空白以外のセルが残っているはずなのですが。

    いずれにせよ、全体を見直してみます。
  • id:icta
    > Mookさん

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

    > と判断できる状況はどのあたりからでしょうか。

    ▼この行からになります。
    .Columns(titleCol).AutoFilter Field:=1, Criteria1:="<" & Range("B1").Value _
    , Operator:=xlOr, Criteria2:=">" & Range("B2").Value
    .Range("A1").CurrentRegion.Select

    > 指定列は、タイトル行の"来店日"を探して処理しているのですが、実際の処理でtitleCol に 来店日の列が入っていないでしょうか。

    上の時点でtitleColには1が入っています。

    > との状況は確かでしょうか。
    > 担当者が空白のものを削除するために、いったん担当者が空白行のみを表示する処理をしています。
    > その直後、表示されている行を全部削除しますので、
    > Selection.EntireRow.Delete
    > それによってこの直後、空白以外のセルが残っているはずなのですが。

    ▲上記のすぐ下にある以下の行で、担当が空白行のみの行が表示されています。来店日は5/1~5/31以内にあります。
    srcWS.Rows(1).Copy
    .Rows(1).Insert shift:=xlDown

    "来店日"列は列位置が正しく判断されているようですが、”担当”の列が期待通りに動作していないようです。

    お手数をおかけして申し訳ありませんが、お時間の許す時にチェックしていただければ幸いです。
  • id:Mook
    あらら、タイトル列に 1ですかぁ。
    それは、完全に想定外ですね。

    ん!?、でもそれは数字の1ではなく、アルファベットの I ではないですか?
    I列が該当の列ではないでしょうか。

    関数仕様として、列はアルファベットを使用しているのですが、ほかのケースでも
    数値が入っていますか?

  • id:icta
    > Mookさん
    新しい回答に気が付きませんでした。
    また1はおっしゃるとおりlでした。
    申し訳ありません。
    新しい回答で改めて検証いたします。
  • id:icta
    > Mookさん

    検証してみました。
    最終的に期待通りの結果が出ることを確認しました。
    ただいくつか疑問点と修正したい点があります。

    オートフィルタの検索対象が"連番"列ではなくて"来店日"列でフィルタリングされるようになりました。
    "来店日"列はI列です。

    疑問点と修正したい点は次のとおりです。

    ○「来店記録」シートのフィルタリングをマクロで外す
    「来店記録」シートには常にオートフィルタをつけています。
    ここでフィルタリングされてているとき、マクロを実行すると希望通りの結果が返ってきません。
    「来店記録」シートのフィルタリングをマクロを実行した時に外すことは可能でしょうか?

    ○タイトル行は削除しない
    仕様では”タイトル行は「担当別売上」シートに入力済み。入力は開始日、終了日、上位のセルの右横セルに入力する。”としています。
    これはタイトル行に背景色をつけて見やすくしているためです。タイトル行を削除せず入力されているものを残すことは可能でしょうか?

    ○"対象の日付範囲だけ残っていますか?"のメッセージ
    このメッセージが表示された時、画面上には何も表示されていません。

    ○"対象のデータが残っていますか?"のメッセージ
    このメッセージが表示された時、画面上には対象のデータが残っています。

    ○スピードが遅い
    開始日~終了日がわずか10日ほどでもマクロを終了するのに私のPCで3分ほどかかります。
    ステップ実行すると▼以下の場所で時間が取られているようです。
    F8を押しっぱなしでもなかなか抜けそうにありません。
    If .Cells(i, titleCol) >= Range("B1").Value Then
    Exit For
    End If
    Next
    このスピードの遅さの原因は恐らく「来店記録」シートが3万行を超えているためと思われます。
    私の仕様に問題があると思いますので、別のフローでスピードを早くする方法はありませんでしょうか?

    度々お手数をおかけして申し訳ありませんが、お時間の許す時にチェックしていただければ幸いです。
  • id:Mook
    (1)まず説明ですが、もともとオートフィルタ対象はI列で、この点はすべての回答で変更していません。
       問題なのは日付によるオートフィル多機能で、この機能はEXCELのバージョンによって動作が異なるようで、
       あまり信頼置ける機能ではなかったようです。
       このため3回目の回答では、日付のフィルタリング処理をやめ対象範囲を処理の中で行うようにしました。

    (2)オートフィルタの機能も、わからない点の一つです。
       3回目の回答では、オートフィルタがかかっていた場合、はずす処理を入れているのですが、
       最初のシートの状態によって、結果が変わるということでしょうか。


    (3)タイトル行の件は修正してみます。

    (4)対象の日付範囲のデータが表示されないのは、一番気がかりな点です。
       TEMP シートの先頭行を見てそのような状態だったでしょうか。
       その結果から、最終結果が出てくるのがわからないのですが・・・。

    (5)ステップ実行の結果からだけでは判断ができませんが、検索処理の改善はして見ます。

  • id:Mook
    2点ほど確認です。
    >オートフィルタの検索対象が"連番"列ではなくて"来店日"列でフィルタリングされるようになりました。
    とありますがこれはご希望の使用でしょうか、それとも希望されない仕様でしょうか。

    連番 も 来店日 時系列で並んでいると解釈しているのですが、問題あったら言ってください。

    当初の仕様にある「セルを保護する」というのが抜けていましたので、上記の変更と併せて修正しますが、
    保護の解除にパスワードは必要ですか?

    また、このシートはスタッフも操作できる環境に置くのでしょうか。
    それとも、ictaさんのみが使用するものですか?
  • id:icta
    > とありますがこれはご希望の使用でしょうか、それとも希望されない仕様でしょうか。
    これは「でもそれは数字の1ではなく、アルファベットの I ではないですか?I列が該当の列ではないでしょうか。」への返信です。
    判りにくくてすみませんでした。

    > 連番 も 来店日 時系列で並んでいると解釈しているのですが、問題あったら言ってください。
    はい、連番も来店日と同じで1,2,5,10・・・のように小さな番号が必ず前に来ます。大きな番号がそれより小さな番号の前に来ることはありません。

    > 当初の仕様にある「セルを保護する」というのが抜けていましたので、上記の変更と併せて修正しますが、
    > 保護の解除にパスワードは必要ですか?
    これに関しては「上位」を入力するセルのみセルの保護をするつもりでした。
    スタッフはエクセルをよく知らないのでセルの保護くらいで十分なのですが、もしセルだけにパスワードを付けられるのであれば便利だと思います。コードが面倒なものになるのであれば必要はありません。

    > このシートはスタッフも操作できる環境に置くのでしょうか。
    このシートは「顧客管理.xls」の中のシートです。
    スタッフも全員、閲覧、マクロの実行をできるようにします。マクロを実行することはまずないと思いますが、先月のトップ3は誰かを誰でもチェックできたりするようにします。
    ただし上位のセルだけはロックしておいて、ワーストがわからないようにします。

    > 3回目の回答では、オートフィルタがかかっていた場合、はずす処理を入れているのですが、
    > 最初のシートの状態によって、結果が変わるということでしょうか。

    「来店記録」シートでフィルタリングしているとデータがあるにもかかわらず「条件に一致する売上データがありません。」というメッセージが表示されます。

    > 対象の日付範囲のデータが表示されないのは、一番気がかりな点です。
    > TEMP シートの先頭行を見てそのような状態だったでしょうか。
    > その結果から、最終結果が出てくるのがわからないのですが・・・。

    ステップ実行では上記のコメントで記載したコードの部分でずっとループしているため確認できません。
    通常の実行ではメッセージが表示された時点では何も表示されていません。
    ただ行数を見ると3万行を超えているのでスクロールができれば前の行が見えるのかもしれませんが、実行中はスクロールできないため確認できません。

    それではお手数をおかけしますがよろしくお願いいたします。
  • id:Mook
    シートの保護をするようにしましたので、条件を変える場合は
    手動でシートの保護を外してから設定ください。

    日付の部分(B1,B2)のみ、「セルの初期設定」⇒「保護」⇒「ロック」を外しておけば、
    保護したままでこのセルのみ変更できます。

    では、ご確認をお願いします。
  • id:icta
    > Mookさん

    早々のご回答ありがとうございました。
    お返事が遅くなりまして申し訳ありません。
    新しく作成していただいた(4)の回答を試してみました。
    私のPCでは過去1年分で上位5名にした場合約2分でした。
    過去1ヶ月で同じく上位5名にした場合も約2分でした。
    前回のものは過去1ヶ月で上位5名の場合、約3分でしたので幾分早くなりました。
    しかしMookさんのPCでは2~3秒とのことでしたので私のPCが低スペックなのだと思います。
    もしかしたらこちらのデータは3万行超、17MB、列数が15行以上、コメント欄がビッチリ書き込まれているためMookさんのサンプルデータよりデータが大きく、コピー&ペーストのときに時間がかかっているのかもしれません。
    いずれにせよ、PCのスペックのせいだとわかりましたので問題はありません。
    お騒がせいたしました。

    次に▼この件に関しては前回同様みたいです。
     「来店記録」シートでフィルタリングしているとデータがあるにもかかわらず
     「条件に一致する売上データがありません。」というメッセージが表示されます。

    バージョンがMookさんのものと異なるためだと思いますので、新しいマクロの記録で、データ>フィルタ>オートフィルタのチェックを外すを試してみたところ、▼次のようになりました
    myCell = ActiveCell.Row
    ActiveSheet.ShowAllData
    ActiveCell.Offset(0, 0).Range("A1").Select
    「来店記録」シートがフィルタリングされていることが多いので、もし可能であればマクロ実行時にフィルタリングを外すことができれば大変便利です。

    最後に後からの仕様変更で大変申し訳ないのですが、▼次のように平均顧客単価を追加していただくことは可能でしょうか?
    単価(平均顧客単価)=売上(合計売上)÷件数(合計件数)

    順位 担当 売上 割合 件数 単価
    1 田中 5000000 20% 500 10000
    2 鈴木 4000000 10% 200 20000
    3 佐藤 3000000 5% 100 30000

    計算式を使えば簡単に出るのですが、マクロで最初から表示されると大変判りやすいです。
    後出しで心苦しい限りのですがお手すきの時にチェックしていただければ幸いです。
  • id:Mook
    うーんどこにそれほど時間がかかっているのでしょうか。
    いくらスペック差があるとはいえ、そこまで違うとは思えないのですが・・・。

    とりあえず、おまじないを入れてみました。

    オートフィルタの件、改善したつもりだったのですが、はずす場所が日付検索後だったので
    問題だったように見えます。
    位置を処理の先頭に移動しました。

    平均単価の件、計算式を、追加しました。
  • id:icta
    > Mookさん

    早々のご回答ありがとうございました。
    早速試してみたのですが400エラーが出てマクロが終了してしまいました。
    ステップ実行で確かめてみるとまず▼この部分で処理に2分くらいかかっています。

    '--- 作業シートを作成
    srcWS.Copy After:=Worksheets(Worksheets.count)
    Worksheets(Worksheets.count).Name = TMP_WS_NAME
    Set tmpWS = Worksheets(TMP_WS_NAME)


    ▼次のこの部分で「実行時エラー'1004';アプリケーション定義またはオブジェクト定義のエラーです」が表示されます。」

    With tmpWS
    If .AutoFilterMode = True Then
    .ShowAllData
    End If

    エクセルのバージョンが違うとコマンドも色々違うみたいですね。
    エクセルのバージョンを上げることは当分先にすることにします。
    何度もお手数をおかけして心苦しいのですがお手すきのときにチェックしてみていただければ幸いです。
  • id:Mook
    エラーが出ている原因が皆目見当がつきませんが、
    後者に関しては以前は動いていたと思われる、以前のコードを使用してみてもらえますか。

     If .AutoFilterMode = True Then
       .ShowAllData
     End If
    のかわりに
     If .AutoFilterMode = True Then
       .Range("A1").AutoFilter
     End If
    を使用してください。

    前者はなぜ2分もかかるかわかりませんが、シートのコピー処理です。
    シートの中に数式やマクロは含まれていますか?
    元のシートのフィルタを外せるのであれば、シートのコピーでも行けそうなのですが、
    ちょっと良い方法が、思い浮かびません。

    関係ないとは思いますが、
    Application.ScreenUpdating
    Application.EnableEvents
    Application.Calculation
    関連(計8か所)をコメントアウトしてみて試してもらえますか。
    エラーが起きたときの状態が、わかると思います。

  • id:icta
    > Mookさん

    早々のご回答ありがとうございました。
    完全に期待通りの動作を確認できました。

    > 前者はなぜ2分もかかるかわかりませんが、シートのコピー処理です。
    > シートの中に数式やマクロは含まれていますか?

    シートの中に数式やマクロは含まれていません。ただ以前教えていただいた入力規則が行ごとに設定されています。
    今回のマクロで過去1年間分で実行したところ2分半で終了しました。
    他のPCで試したところ、多少早く終了しましたのでやはり処理時間はPCのスペックのようです。
    期待通りの結果が得られましたのでこれにて質問を終了いたします。
    後からの仕様変更などにも丁寧に対応していただいてありがとうございました。
    次の機会にもお知恵とお力をお借りできれば幸いです。
  • id:Mook
    動いたようでなによりですが、2分は何とかしたかったですね。

    シートコピーに時間がかかっているのであれば、シートのコピーではなく必要な行のみのコピーにしたかったのですが、
    そのためには元のシートのオートフィルタを外す必要があり、マクロを動かすたびにフィルタが外れるのはまずい気が
    したので、今回はシートコピーのままにしました。

    またの機会があれば、改善したいところです。

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

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

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

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