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

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

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

▽最新の回答へ

1 ● Mook
●0ポイント

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

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


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

2 ● Mook
●0ポイント

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

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

3 ● Mook
●0ポイント

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 を削除ください。


4 ● Mook
●0ポイント

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

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


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

5 ● Mook
●1500ポイント

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

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
関連質問


●質問をもっと探す●



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