複数のシートからLARGE関数で抽出したセルが該当する行全体の情報を表示させたい。

EXCEL2010で複数（約14シート）からLARGE関数で金額の高い上位数名を表示させてます。
この金額のある行を表示させる為、何か良い方法がないでしょうか？

添付画像のように、1～10行目までに=LARGE(A:N!O5:O1048214,1)　の式で1～10位迄
出しており、この10行分の項目を下に一覧で出したいのです。

現在は「すべてのシートを選択」し、「検索」で「*位の金額を入力」し、該当箇所に飛んだら
「シートを解除」し、行をコピペする、という作業を10回しています。

質問者からの補足コメント

• 先ほどNo.3で頂いたのを貼り付けてやってみたのですが、
  今度は「sheet」ができて、「a1セル」に「ダミー」という言葉が入り、
  エラー400　と出て終わってしまいました…。
  
  EXCELは**データ 27.05.xlsmという名前で、sheet名は各支店番号「**」と
  つけてあります。上書き保存する度に閉めて再度開いています。
  
  Alt+F8から「ステップイン」を選ぶと1行目の「Sub Sample2()」が黄色くマーキング
  されました。Alt+F8から「実行」をする度にシートが増えていき、
  A1セルに「ダミー」と入っていきます。
  
  うまく説明できずにすみません。画像を添付します。

  
  No.4の回答に寄せられた補足コメントです。 補足日時：2015/06/08 16:50

• ご連絡遅くなって申し訳ありませんでした。
  ようやく時間が取れて、No.5＆6で再試行してみました。が、やはり「400」と出て
  エラーになってしまいました。
  
  で、関係あるかどうかも分からないのですが、各シートのレイアウトが
  影響しているのかも？と思って補足します。
  添付画像0612左のように、各シートは1～4行目はシート内の合計値を算出させており、
  5行目は空白、6行目にヘッダーにあたる部分があり、7行目から一覧を出しています。
  計算式は添付画像0612右です。
  
  13シート全てが上記と同じレイアウトになっており、
  14シート目の「計」シートのＭ～Ｑ列で串刺し計算をしたものを出し、
  「計」シートのＩ列でLARGE関数で数値を出す、と設定してあります。
  関係ありますでしょうか？
  
  もしお時間がありましたら、あと少しお付き合い頂けると嬉しいです。
  よろしくお願い致します。

  
    補足日時：2015/06/12 16:08

No.5 ベストアンサー 回答者： tom04 回答日時： 2015/06/08 19:03

続けてお邪魔します。

画像を拝見すると、「計」Sheetの16行目はなにもデータがないのですね？
今までのコードは16行目が項目行になっている前提のコードで、
A列最終行の1行下へ随時データを貼り付けるようにしていました。
A16セルにデータがないというコトなのでA2セルに表示されたと思います。
もう一度コードに手を加えてみました。

＞Alt+F8から「実行」をする度にシートが増えていき・・・
途中でエラーになっているために作業用のSheetがどんどん増えてきているものと思われます。
現状の状態で不要なSheet見出し上で右クリック　→　削除　→　注意画面が出ますが、無視してSheetを削除してください。
（不要なSheetをすべて削除します）
そうした上で今までのコードはすべて消去し、↓のコードにしてみてください。

Sub Sample3()
Dim i As Long, k As Long, lastRow As Long, myRow As Long, lastCol As Long
Dim str As String, c As Range, r As Range, wS As Worksheet
Application.ScreenUpdating = False
Set wS = Worksheets("計")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
'//↓★項目行より後のデータを消去
lastCol = wS.Cells(16, Columns.Count).End(xlToLeft).Column
If lastRow > 16 Then
Range(wS.Cells(17, "A"), wS.Cells(lastRow, lastCol)).ClearContents
End If
'//↑★
Worksheets.Add after:=Worksheets(Worksheets.Count)
With Worksheets(Worksheets.Count)
.Range("A1") = "ダミー"
For k = 1 To 14 '//「A」Sheet～「N」Sheetまで（Sheet見出しの一番左～14番目のSheetまで）
Set wS = Worksheets(k)
lastCol = wS.Cells(4, Columns.Count).End(xlToLeft).Column
lastRow = wS.Cells(Rows.Count, "O").End(xlUp).Row
If lastRow > 4 Then
With Range(wS.Cells(5, lastCol + 1), wS.Cells(lastRow, lastCol + 1))
.Formula = "=MID(CELL(""filename"",A1),FIND(""]"",CELL(""filename"",$A$1))+1,31)&""_""&O5"
.Value = .Value
End With
myRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Range(wS.Cells(5, "O"), wS.Cells(lastRow, "O")).Copy
.Cells(myRow, "A").PasteSpecial Paste:=xlPasteValues
Range(wS.Cells(5, lastCol + 1), wS.Cells(lastRow, lastCol + 1)).Copy
.Cells(myRow, "B").PasteSpecial Paste:=xlPasteValues
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
With Range(.Cells(2, "C"), .Cells(lastRow, "C"))
.Formula = "=RANK(A2,A:A)"
.Value = .Value
End With
End If
.Range("A1").CurrentRegion.Sort key1:=.Range("C1"), order1:=xlAscending, Header:=xlYes
End If
Next k
.Range("A1").CurrentRegion.Sort key1:=.Range("A1"), order1:=xlDescending, Header:=xlYes
Set wS = Worksheets("計")
'//▼ココから
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row '//★
If .Cells(i, "C") > 10 Then Exit For
str = Left(.Cells(i, "B"), InStr(.Cells(i, "B"), "_") - 1)
Set c = Worksheets(str).Range("O:O").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
Worksheets(str).Cells(c.Row, "A").Resize(, lastCol).Copy wS.Cells(i + 15, "A") '//17行目から★
Next i
For k = 1 To 14
Worksheets(k).Columns(lastCol + 1).Clear
Next k
'//▲ココまで
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　「計」Sheetの16行目（項目行）で最終列を取得していますので、
16行目は他のSheetと同じ項目名を同じ列数だけ入力しておいてください。

※　今回は作業用のSheetの上位10位まですべてを「計」Sheetの17行目以降に表示するようにしてみました。

これではどうでしょうか？m(_ _)m

この回答へのお礼

何度もご提案頂き、ありがとうございます。
が、やはり「400」エラー表示→OK→Sheet作成→a1にダミー文字
という状態になり、うまく動きませんでした。
残念ながら、ここで一度締め切ろうと思います。
長々とご協力頂きありがとうございました。

お礼日時：2015/06/15 16:43

No.7 回答者： tom04 回答日時： 2015/06/12 19:56

またまた顔を出します。

アップされている画像は小さすぎて詳細が判らないのですが、
＞6行目にヘッダーにあたる部分があり、7行目から一覧を出しています。
すなわち各Sheetの6行目が項目行でデータは7行目以降にあるのですね？

最初の質問文の中に
＞=LARGE(A:N!O5:O1048214,1)　の式で・・・
とありましたので、勝手に4行目が項目行でデータは5行目以降にあるものだと判断してのコードでした。
↓のコードにしてみてください。

Sub Sample4()
Dim i As Long, k As Long, lastRow As Long, myRow As Long, lastCol As Long
Dim str As String, c As Range, r As Range, wS As Worksheet
Application.ScreenUpdating = False
Set wS = Worksheets("計")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
lastCol = wS.Cells(16, Columns.Count).End(xlToLeft).Column
If lastRow > 16 Then
Range(wS.Cells(17, "A"), wS.Cells(lastRow, lastCol)).ClearContents
End If
Worksheets.Add after:=Worksheets(Worksheets.Count)
With Worksheets(Worksheets.Count)
.Range("A1") = "ダミー"
For k = 1 To 14 '//「A」Sheet～「N」Sheetまで（Sheet見出しの一番左～14番目のSheetまで）
Set wS = Worksheets(k)
lastCol = wS.Cells(6, Columns.Count).End(xlToLeft).Column '←各Sheet6行目で最終列取得//★
lastRow = wS.Cells(Rows.Count, "O").End(xlUp).Row
If lastRow > 6 Then '//★
With Range(wS.Cells(7, lastCol + 1), wS.Cells(lastRow, lastCol + 1)) '//★
.Formula = "=MID(CELL(""filename"",A1),FIND(""]"",CELL(""filename"",$A$1))+1,31)&""_""&O5"
.Value = .Value
End With
myRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Range(wS.Cells(7, "O"), wS.Cells(lastRow, "O")).Copy '//★
.Cells(myRow, "A").PasteSpecial Paste:=xlPasteValues
Range(wS.Cells(7, lastCol + 1), wS.Cells(lastRow, lastCol + 1)).Copy '//★
.Cells(myRow, "B").PasteSpecial Paste:=xlPasteValues
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
With Range(.Cells(2, "C"), .Cells(lastRow, "C"))
.Formula = "=RANK(A2,A:A)"
.Value = .Value
End With
End If
.Range("A1").CurrentRegion.Sort key1:=.Range("C1"), order1:=xlAscending, Header:=xlYes
End If
Next k
Set wS = Worksheets("計")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(i, "C") > 10 Then Exit For
str = Left(.Cells(i, "B"), InStr(.Cells(i, "B"), "_") - 1)
Set c = Worksheets(str).Range("O:O").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
Worksheets(str).Cells(c.Row, "A").Resize(, lastCol).Copy wS.Cells(i + 15, "A")
Next i
For k = 1 To 3
Worksheets(k).Columns(lastCol + 1).Clear
Next k
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　コード内の「★」の部分で行合わせしています。
（前回の「5」が「7」に変わっているヶ所が多々あると思います）

今度はどうでしょうか？m(_ _)m

No.6 回答者： tom04 回答日時： 2015/06/08 19:55

何度もごめんなさい。

前回のコードで無意味な行がありました。
＞Next k
の次の

＞.Range("A1").CurrentRegion.Sort key1:=.Range("A1"), order1:=xlDescending, Header:=xlYes
の1行を消去してください。

どうも失礼しました。m(_ _)m

No.4 回答者： tom04 回答日時： 2015/06/07 19:44

No.1・3です。

たびたびごめんなさい。
エラーの原因について、投稿後思ったのですが、
試し用の新しいBookで操作されていませんか？

各Sheet名を取得するため、ワークシート関数のCELL関数を使用しています。
これは名前付きファイルの場合のみ有効ですので、
どんな名前でも良いので、一旦ファイルを保存　→　新たに開きなおしてマクロを実行してみてください。
そうしないとSheet名の取得ができません。
これがエラーの直接の原因かどうか判りませんが、試してみてください。

※　尚、前回のコードは「計」Sheetのランク（I列）一切無視してすべてのデータを並び替え、
上位10位を表示するようにするコードです。m(_ _)m

No.3 回答者： tom04 回答日時： 2015/06/07 19:23

No.1です。

＞「計シート」の2行目(16行目ではなく）に第1位の方の情報が反映されたのですが

どうも失礼しました。項目行を1行見間違えていました。
前回のコードは項目行が15行目になっているというコードですので、
今回は16行目が項目行でデータは17行目以降に表示させるコードにしてみました。
前回の修正部分はコード内の▼～▲になっています。

Sub Sample2()
Dim i As Long, k As Long, lastRow As Long, myRow As Long, lastCol As Long
Dim str As String, c As Range, r As Range, wS As Worksheet
Application.ScreenUpdating = False
Set wS = Worksheets("計")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
'//↓★項目行より後のデータを消去
lastCol = wS.Cells(16, Columns.Count).End(xlToLeft).Column
If lastRow > 16 Then
Range(wS.Cells(17, "A"), wS.Cells(lastRow, lastCol)).ClearContents
End If
'//↑★
Worksheets.Add after:=Worksheets(Worksheets.Count)
With Worksheets(Worksheets.Count)
.Range("A1") = "ダミー"
For k = 1 To 14 '//「A」Sheet～「N」Sheetまで（Sheet見出しの一番左～14番目のSheetまで）
Set wS = Worksheets(k)
lastCol = wS.Cells(4, Columns.Count).End(xlToLeft).Column
lastRow = wS.Cells(Rows.Count, "O").End(xlUp).Row
If lastRow > 4 Then
With Range(wS.Cells(5, lastCol + 1), wS.Cells(lastRow, lastCol + 1))
.Formula = "=MID(CELL(""filename"",A1),FIND(""]"",CELL(""filename"",$A$1))+1,31)&""_""&O5"
.Value = .Value
End With
myRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Range(wS.Cells(5, "O"), wS.Cells(lastRow, "O")).Copy
.Cells(myRow, "A").PasteSpecial Paste:=xlPasteValues
Range(wS.Cells(5, lastCol + 1), wS.Cells(lastRow, lastCol + 1)).Copy
.Cells(myRow, "B").PasteSpecial Paste:=xlPasteValues
End If
Next k
.Range("A1").CurrentRegion.Sort key1:=.Range("A1"), order1:=xlDescending, Header:=xlYes
Set wS = Worksheets("計")
'//▼ココから
For i = 2 To 11 '//←「作業用Sheet」のSheetの上位10位まで(1行目が項目行のため）★
str = Left(.Cells(i, "B"), InStr(.Cells(i, "B"), "_") - 1)
Set c = Worksheets(str).Range("O:O").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
Worksheets(str).Cells(c.Row, "A").Resize(, lastCol).Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1)
Next i
For k = 1 To 14
Worksheets(k).Columns(lastCol + 1).Clear
Next k
'//▲ココまで
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　今度はどうでしょうか？m(_ _)m

No.2 回答者： hallo-2007 回答日時： 2015/06/06 08:48

>現在は「すべてのシートを選択」し、「検索」で「*位の金額を入力」し、該当箇所に飛んだら

>「シートを解除」し、行をコピペする、という作業を10回しています。
一案ですが
オートフィルターに、トップテンと云う機能があります（バージョンにもよります）
操作方法
１．データの範囲を選択して、オートフィルターを設定
２、金額の列で、数値フィルター＝＞トップテンをクリック
３、順位など指定してＯＫ
４、上位トップテンが表示されますので、そのままコピー
５、表示したい部分へ貼り付け
６、フィルターは解除

上記の操作で可能だと思います。
一度、マクロの記録を実行すれば、次からはボタン操作だけで
可能になります。

この回答へのお礼

回答ありがとうございます。
複数シートを選択してのオートフィルってできないですよね？
14シートあるので1シート毎にこの作業を行うなら、
今やっている作業とあまり変わらないのです。
質問の仕方がわかりづらく申し訳ありませんでした。

お礼日時：2015/06/07 14:55

No.1 回答者： tom04 回答日時： 2015/06/06 00:15

こんばんは！

VBAになりますが、一例です。

＞1～10行目までに=LARGE(A:N!O5:O1048214,1)　の式で1～10位迄
出しており・・・
というコトですが、同順位が懸念されます。
とりあえず同一Sheet内に同順位はなく、別Sheetで同順位があっても対応できるようにしてみました。

画像を拝見すると「計」Sheetの15行目が項目行になっていて、行がかなり飛んで表示されていますが、
16行目以降に表示するコードにしてみました。

Alt+F11キー　→　メニュー　→　挿入　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻り（VBE画面を閉じて）マクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() '//この行から
Dim i As Long, k As Long, lastRow As Long, myRow As Long, lastCol As Long
Dim str As String, c As Range, r As Range, wS As Worksheet
Application.ScreenUpdating = False
Set wS = Worksheets("計")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
lastCol = wS.Cells(15, Columns.Count).End(xlToLeft).Column
If lastRow > 15 Then
Range(wS.Cells(16, "A"), wS.Cells(lastRow, lastCol)).ClearContents
End If
Worksheets.Add after:=Worksheets(Worksheets.Count)
With Worksheets(Worksheets.Count)
.Range("A1") = "ダミー"
For k = 1 To 14 '//「A」Sheet～「N」Sheetまで（Sheet見出しの一番左～14番目のSheetまで）
Set wS = Worksheets(k)
lastCol = wS.Cells(4, Columns.Count).End(xlToLeft).Column
lastRow = wS.Cells(Rows.Count, "O").End(xlUp).Row
If lastRow > 4 Then
With Range(wS.Cells(5, lastCol + 1), wS.Cells(lastRow, lastCol + 1))
.Formula = "=MID(CELL(""filename"",A1),FIND(""]"",CELL(""filename"",$A$1))+1,31)&""_""&O5"
.Value = .Value
End With
myRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Range(wS.Cells(5, "O"), wS.Cells(lastRow, "O")).Copy
.Cells(myRow, "A").PasteSpecial Paste:=xlPasteValues
Range(wS.Cells(5, lastCol + 1), wS.Cells(lastRow, lastCol + 1)).Copy
.Cells(myRow, "B").PasteSpecial Paste:=xlPasteValues
End If
Next k
.Range("A1").CurrentRegion.Sort key1:=.Range("A1"), order1:=xlDescending, Header:=xlYes
Set wS = Worksheets("計")
For i = 1 To 10 '//←「計」SheetのI1～I10セル
Set c = .Range("A:A").Find(what:=wS.Cells(i, "I"), LookIn:=xlValues, lookat:=xlWhole)
str = Left(.Cells(c.Row, "B"), InStr(.Cells(c.Row, "B"), "_") - 1)
Set r = Worksheets(str).Columns(lastCol + 1). _
Find(what:=.Cells(c.Row, "B"), LookIn:=xlValues, lookat:=xlWhole)
Worksheets(str).Cells(r.Row, "A").EntireRow.Copy _
wS.Cells(Rows.Count, "A").End(xlUp).Offset(1)
Next i
wS.Columns(lastCol + 1).Clear
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub '//この行まで

※　一発で解決！とはいかないと思いますが、
とりあえずはこの程度で・・・m(_ _)m

この回答へのお礼

回答ありがとうございます。マクロ実行したところ、
str = Left(.Cells(c.Row, "B"), InStr(.Cells(c.Row, "B"), "_") - 1)で、
実行時エラー'91'　オブジェクト変数またはwithブロック変数が設定されていません
と出て、できませんでした。
後、「計シート」の2行目(16行目ではなく）に第1位の方の情報が
反映されたのですが、2位以下は表示されませんでした。

お礼日時：2015/06/07 15:06