Excel シート毎の比較、抽出

質問

教えて頂きたい事が、二つあります。

sheetの名前が
「合計」「レモン」「みかん」「オレンジ」「ブドウ」「ひな形」とあります。

(1)各果物のSheetのセル(R7C6)に売上率が書いています（数値）
　各果物のSheet毎に売上率を比べて
　「合計」Sheetの同位置のセル(R7C6)に、一番高い売上率を表示させたい。

(2)もう一つは
　各果物のSheetのあるセル(R7C7)に色が書いてあります（文字列）
　書いてないこともあります。
　「合計」Sheetの同位置のセル(R7C7)に各Sheetより抽出したデータを
　表示させたい。

　例えば
　　　Sheet　「レモン」「みかん」「オレンジ」「ブドウ」「ひな形」
　　　R7C7　　　 黄　　　　紫　　　（空欄）　　 群青　　（空欄）

　　　でSheet「合計」セル(R7C7)に
　　　　　　　　[黄　紫　群青］
　　　と言うような具合。

　　「＝レモン!R7C7&"　"&みかん!R7C7&"　"&オレンジ!R7C7&"　"&ブドウ!R7C7」
　　　とすると、スペース分が出てしまい、綺麗に表示されません。

今後フルーツが増えていく予定
（「合計」「レモン」「みかん」「オレンジ」「ブドウ」「メロン」「ひな形」）
（「合計」「レモン」「みかん」「オレンジ」「ブドウ」「りんご」「メロン」「ひな形」）
（「合計」「パイナップル」「レモン」「みかん」「オレンジ」「ブドウ」「りんご」「メロン」「ひな形」）
なので間（合計が先頭でひな形が一番後ろ）に新しいsheetが入っても、対応できるような式がいいのですが・・・

回答No.5

mz80 · ベストアンサー

(1)Book内の総シート数Cntの設定のコーディングがなくなっています。このため、For i=1 To Cnt のループが１回も実行されません。結果、売り上げは０　色は空欄となります。

(2)最大売上を最小値0に、また、色を空っぽにするのは、行のループ内です。

(3)処理しないシート名が「レモン」と「ひな型」以外になっています。「レモン」でなく「合計」だと思います。

およそ500行で「レモン」～「ぶどう」の4シートで5秒くらいかかりますね（私のPCだと）。シートが増えるとかなり動作が遅くなりそうな。

Sub Uriage()

Dim SaidaiUriage As Long
Dim UriageIroGyo As Integer
Dim UriageRetu As Integer
Dim Iro As String
Dim IroRetu As Integer
Dim Cnt, i As Integer

UriageRetu = 6
IroRetu = 7

'Book内の総シート数　(1)の指摘事項
Cnt = Worksheets.Count

For UriageIroGyo = 7 To 501
'最大売上を最小値0に、また、色を空っぽにする　(2)の指摘事項
SaidaiUriage = 0
Iro = ""

'各シートの同一行を比較し、最大売上と色を求める
For i = 1 To Cnt
'(3)の指摘事項
If Not ((Worksheets(i).Name = "合計") Or (Worksheets(i).Name = "ひな形")) Then
'売上の大きいのはどちらか
If (Worksheets(i).Cells(UriageIroGyo, UriageRetu).Value > SaidaiUriage) Then
SaidaiUriage = Worksheets(i).Cells(UriageIroGyo, UriageRetu).Value
End If

'色取得
If Not IsEmpty(Worksheets(i).Cells(UriageIroGyo, IroRetu).Value) Then
Iro = Iro & "　" & Worksheets(i).Cells(UriageIroGyo, IroRetu).Value
End If

End If
Next i

Worksheets("合計").Cells(UriageIroGyo, UriageRetu).Value = SaidaiUriage
Worksheets("合計").Cells(UriageIroGyo, IroRetu).Value = Iro

Next UriageIroGyo

End Sub

お礼

できました！感動です (T T)
なんも知らない自分に
ホントにありがとうございます。

回答No.4

mz80

No.1です。
細かなことは長くなるので、ご自身のコーディングと比較して見てください。

MORICKさんの作られた構想は、1つのシート内の有効な行でループし売上を取得。次のシートに移り、先ほどのシートの売上と行ごとに比較し最大を求める。これをシート数分繰る返すとなっています。
この場合、全シートでの処理が終わらないと各行の最大売上が決まらないため、行数分の最大売上を覚えておく場所が必要です(dimで配列を定義)。で、この考えは素直な考え方です。もし、行が固定で10とか決まるのであれば、この構想でOKです。

シート内のデータの入った行数は、excelから教えてもらえないようです。rows.countは、範囲指定時の行数で指定していないと65565みたいです(本当はあるのかもしれません。私が知らないだけかも)。
そこで、基本となる行数をシート「レモン」の売上欄が空っぽでない行までとして最初に数え、1行ごとの比較を全シートで行い、シート「合計」に結果を書き込み、これを行数分繰り返す様な構想に変更しました。

あと、これはつけたしですが、イベントプロシージャー、この場合Worksheet_Activateですが、ここに直接コーディングを入れるのは、勉強するのには、余りよくないのです。そこで、本来の処理は、標準モジュールに作成し、Worksheet_Activateの中は、1行だけCALL文を入れるようにしました。動作がおかしい場合、このCALL文をコメントにしてしまえば、プログラムは動かなくなるという利点もあります。

内容は
シート合計のモジュールは
Option Explicit
Private Sub Worksheet_Activate()
Call Uriage

End Sub

標準モジュールは
Option Explicit
Sub Uriage()
'シート「合計」からWorksheet_Activateで呼び出される
'シート「レモン」の売上欄、7列目に行方向に連続で値が
'入っているものとし、各シートはその行数分処理する
'
Dim SaidaiUriage As Long
Dim UriageIroGyo As Integer
Dim UriageRetu As Integer
Dim Iro As String
Dim IroRetu As Integer
Dim Cnt, i As Integer
Dim myLastRow As Long

UriageRetu = 6
IroRetu = 7

'Book内の総シート数
Cnt = Worksheets.Count

'シート「レモン」の売上欄には、有効な行数分連続で値が
'入っているものとして
'処理行数を決定する。1行目から調べ、未入力行で終了
i = 1
While (Not IsEmpty(Worksheets("レモン").Cells(i, UriageRetu).Value))
i = i + 1
Wend

'未入力行の行番号なので処理する行より1つ多い。
'マイナス1して、処理行数とする
myLastRow = i - 1

'最大売上の取得ループ
'行数分ループ
For UriageIroGyo = 1 To myLastRow
'最大売上を最小値0に、また、色を空っぽにする
SaidaiUriage = 0
Iro = ""

'各シートの同一行を比較し、最大売上と色を求める
For i = 1 To Cnt
If ((Worksheets(i).Name = "合計") Or (Worksheets(i).Name = "ひな形")) Then
'何もしない
Else
'売上の大きいのはどちらか
If (Worksheets(i).Cells(UriageIroGyo, UriageRetu).Value > SaidaiUriage) Then
SaidaiUriage = Worksheets(i).Cells(UriageIroGyo, UriageRetu).Value
End If

'色取得
If Not IsEmpty(Worksheets(i).Cells(UriageIroGyo, IroRetu).Value) Then
Iro = Iro & "　" & Worksheets(i).Cells(UriageIroGyo, IroRetu).Value
End If

End If
Next i

Worksheets("合計").Cells(UriageIroGyo, UriageRetu).Value = SaidaiUriage
Worksheets("合計").Cells(UriageIroGyo, IroRetu).Value = Iro
Next UriageIroGyo

End Sub

補足

＞シート「レモン」の売上欄、7列目に行方向に連続で値が入っているものとし、
なんですが入ってません（汗）途中空欄の行が数カ所あります。
ただ列は５０１行と決まってるので以下のように作ってみたのですが・・・
マクロは動いてはいるのですが、
売り上げは０　色は空欄のままです。なぜなんでしょうか・・・？

Option Explicit
Sub Uriage()

Dim SaidaiUriage As Long
Dim UriageIroGyo As Integer
Dim UriageRetu As Integer
Dim Iro As String
Dim IroRetu As Integer
Dim Cnt, i As Integer
Dim myLastRow As Long

UriageRetu = 6
IroRetu = 7

'最大売上を最小値0に、また、色を空っぽにする
SaidaiUriage = 0
Iro = ""

For UriageIroGyo = 7 To 501

'各シートの同一行を比較し、最大売上と色を求める
For i = 1 To Cnt
If Not ((Worksheets(i).Name = "レモン") Or (Worksheets(i).Name = "ひな形")) Then
'何もしない

'売上の大きいのはどちらか
If (Worksheets(i).Cells(UriageIroGyo, UriageRetu).Value > SaidaiUriage) Then
SaidaiUriage = Worksheets(i).Cells(UriageIroGyo, UriageRetu).Value
End If

'色取得
If Not IsEmpty(Worksheets(i).Cells(UriageIroGyo, IroRetu).Value) Then
Iro = Iro & "　" & Worksheets(i).Cells(UriageIroGyo, IroRetu).Value
End If

End If
Next i

Worksheets("合計").Cells(UriageIroGyo, UriageRetu).Value = SaidaiUriage
Worksheets("合計").Cells(UriageIroGyo, IroRetu).Value = Iro

Next UriageIroGyo

End Sub

回答No.3

NNAQ

(1)は単純に
=MAX(レモン:ひな形!RC)

(2)はシートを追加するならVBAのほうがいいですが、力技なら
=IF(レモン!RC<>"",レモン!RC,"")&IF(みかん!RC<>""," "&みかん!RC,"")&IF(オレンジ!RC<>""," "&オレンジ!RC,"")&IF(ブドウ!RC<>""," "&ブドウ!RC,"")&IF(・・・・・・

回答No.2

mz80

No.1です。
集計をするタイミングは、合計シートをクリックした時とした場合…

１．メニューでツール→マクロ→Visial Basic Editorを選択します。VBEの画面が表示されます。
２．画面は、普通「プロジェクト－VBAProject」というタイトルのウインドウが左に表示されるはずです。
出ていなければ、VBE画面のメニューで表示→プロジェクトエクスプローラを選択します。ウインドウが表示されます。
３．プロジェクトウインドウにはフォルダーのアイコンの下にシート名のぶら下がった一覧が出ています。合計のシートをダブルクリックします。コード入力のウインドウが開きます。
４．回答のコーディングをコピーし、コード入力のウインドウに貼り付けます。

これでいいはずです。やってみてください。最初は誰でもわからないものです(^^;

Worksheet_Activateというプログラムのモジュール名は、決まり文句でそのシートが選択されたとき、excelが自動的に呼び出すものです。

集計のタイミングを自分でボタンでクリックする、あるいは、メニューのツール→マクロから選ぶのであれば
「Worksheet_Activate」を別な名前、例えば「Uriage」とかにして、標準モジュールに貼り付けていただければOKだと思います。

お礼

できました。と言うか、できてました（汗
てっきり普通の式入力のように何か表示されるものだと思ってて。ありがとうございます。

これは他の行もする場合はどうしたらよろしいのでしょうか・・・頑張ってみたのですが動きません。

Private Sub Worksheet_Activate()
Dim SaidaiUriage As Long
Dim UriageGyo, UriageRetu As Integer
Dim Iro As String
Dim IroGyo, IroRetu As Integer
Dim Cnt, i As Integer
Dim j As Integer
Dim myLastRow As Integer

UriageGyo = j
UriageRetu = 6

IroGyo = j
IroRetu = 7

SaidaiUriage = 0
Iro = ""

'Book内の総シート数
Cnt = Worksheets.Count
myLastRow = Rows.Count

'最大売上の取得ループ
For i = 1 To Cnt
For j = 1 To myLastRow
If ((Worksheets(i).Name = "合計") Or (Worksheets(i).Name = "ひな形")) Then
'何もしない
Else
'売上の大きいのはどちらか
If (Worksheets(i).Cells(UriageGyo(j), UriageRetu).Value > SaidaiUriage) Then
SaidaiUriage = Worksheets(i).Cells(UriageGyo(j), UriageRetu).Value
End If

'色取得
If Not IsEmpty(Worksheets(i).Cells(IroGyo(j), IroRetu).Value) Then
Iro = Iro & "　" & Worksheets(i).Cells(IroGyo(j), IroRetu).Value
End If

End If
Next j
Next i

Worksheets("合計").Cells(UriageGyo, UriageRetu).Value = SaidaiUriage
Worksheets("合計").Cells(IroGyo, IroRetu).Value = Iro

End Sub

回答No.1

mz80

マクロならこんな感じです。
ここでは、計算するタイミングをシートの合計が選択された時点で行っています(シート名、合計のActivateイベントプロシージャとしてコーディングしています)。そのあたりは、調整してください(ボタンを作ってクリックした時点で計算する等)。

Option Explicit
Private Sub Worksheet_Activate()
Dim SaidaiUriage As Long
Dim UriageGyo, UriageRetu As Integer
Dim Iro As String
Dim IroGyo, IroRetu As Integer
Dim Cnt, i As Integer

UriageGyo = 7
UriageRetu = 6
IroGyo = 7
IroRetu = 7

SaidaiUriage = 0
Iro = ""

'Book内の総シート数
Cnt = Worksheets.Count
'最大売上の取得ループ
For i = 1 To Cnt
If ((Worksheets(i).Name = "合計") Or (Worksheets(i).Name = "ひな形")) Then
'何もしない
Else
'売上の大きいのはどちらか
If (Worksheets(i).Cells(UriageGyo, UriageRetu).Value > SaidaiUriage) Then
SaidaiUriage = Worksheets(i).Cells(UriageGyo, UriageRetu).Value
End If

'色取得
If Not IsEmpty(Worksheets(i).Cells(IroGyo, IroRetu).Value) Then
Iro = Iro & "　" & Worksheets(i).Cells(IroGyo, IroRetu).Value
End If
End If
Next i

Worksheets("合計").Cells(UriageGyo, UriageRetu).Value = SaidaiUriage
Worksheets("合計").Cells(IroGyo, IroRetu).Value = Iro

End Sub

(字下げが表示されず大変見にくくなっています。)

お礼

ありがとうございます。。。
なんですが、マクロを一度も使用したことがないもので・・・（汗

.メニューの「挿入」→「標準モジュール」
．標準モジュールに以下のＶＢＡコードをコピーペーストします。
．ワークシートからメニューの「ツール」→「マクロ」→「マクロ」で、出てきたものを選択肢して、実行

とあったので見よう見まねでしましたが
このやり方でやっても「Worksheet_Activate()」が
出てこないので実行できません（涙

すいません初心者で。。。