Excelでの、２つ以上の等しい文字列について。

質問

Excelで作った表で、表内に等しい同じ文字が２つ以上ある場合に違うセルに抽出するということは出来るのでしょうか。
例えば果物の表があって、その表に「りんご」という文字が3つあった場合に指定してるセルに「りんご」と表示され、等しい数まで抽出されるようにしたいのです。
説明下手なので画像でアップします。画像みたいな感じのをExcelで出来るなら、ご伝授頂きたい。
http://uploda.cc/img/img5193fd1c509d3.PNG

回答No.1

KURUMITO · ベストアンサー

果物の名前が2つ以上あったらその果物の名前を表示し、その名前が幾つあるかを表示させるとのことですが、名前をリストアップすることが難しいことですね。配列数式などを使ってもできないことではないですが計算にかなりの負担がかかります。そのため作業列を作って対応することがよいでしょう。
お示しの表でしたら例えばＫ4セルには次の式を入力して下方にドラッグコピーします。

=IF(INDEX(B:F,ROUNDUP(ROW(A1)/5,0)+3,MOD(ROW(A1)-1,5)+1)="","",INDEX(B:F,ROUNDUP(ROW(A1)/5,0)+3,MOD(ROW(A1)-1,5)+1))

これによってＢ4セルからＦ列の6行目以降までもの範囲に果物の名前が入力されている場合でもそのすべてをＫ列に表示させることができます。
次にＬ4セルには次の式を入力して下方にドラッグコピーします。

=IF(K4="","",IF(AND(COUNTIF(K$4:K4,K4)=1,COUNTIF(K:K,K4)>1),MAX(L$3:L3)+1,""))

そこでそれらの作業列のデータを使ってお求めの表を作ります。
Ｈ4セルには次の式を入力して下方にドラッグコピーします。

=IF(ROW(A1)>MAX(L:L),"",INDEX(K:K,MATCH(ROW(A1),L:L,0)))

Ｉ4セルには次の式を使って下方にドラッグコピーします。

=IF(H4="","",COUNTIF(K:K,H4))

このように作業列を使って処理することで比較的簡単な式を使って対応することができますし、ＢからＦ列での果物が下方に新たにたくさん入力されることが有っても問題なく対応することができます。
なお、作業列が目障りでしたらそれらの列を選択して右クリックし「非表示」を選択すればよいでしょう。

お礼

どうもありがとうございます。
とても分かりやすく簡単に導入できましたm(_ _ )m

回答No.4

cj_mover

すみません、一応、エラー処理追加しておきます。

関数が返す行数よりも
数式を設定した範囲の行数の方が少ない場合
という特殊なケースへの対応です。

それから、書き忘れましたが、
数式を設定する範囲を１列にした場合は
重複があるキーだけを表示して、数は表示しないような
使い方もできますので。

２行書き加えただけですが、まるごと差し替えてくださいませ。
以下、標準モジュールに過不足なく貼り付け

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Option Explicit ' cj8090042
Private oDict As Object

Function 重複リスト(範囲 As Range)
　　Dim mtxSrc() ' 元データ[二次元配列]
　　Dim mtxPrt() ' 出力データ[二次元配列]
　　Dim arrKeys() ' キー[一次元配列]
　　Dim arrItems() ' キーをカウントした数[一次元配列]
　　Dim v ' ループ用
　　Dim tnRows As Long ' 呼び出し側セル範囲の行数
　　Dim nRow As Long ' 出力行位置
　　Dim i As Long ' ループ用

　　mtxSrc() = 範囲.Value
　　tnRows = Application.Caller.Rows.Count

　　If oDict Is Nothing Then Set oDict = CreateObject("Scripting.Dictionary")
　　For Each v In mtxSrc()
　　' ' 重複を除いたキーを作成しながら、キーの数をItemとしてカウント
　　　　oDict(v) = oDict(v) + 1
　　Next
　　Erase mtxSrc()

　　arrKeys() = oDict.Keys
　　arrItems() = oDict.Items

　　ReDim mtxPrt(1 To tnRows, 1 To 2)
On Error Resume Next
　　For i = 1 To oDict.Count
　　　　If arrItems(i - 1) > 1 Then
　　　　　　nRow = nRow + 1
　　　　　　mtxPrt(nRow, 1) = arrKeys(i - 1)
　　　　　　mtxPrt(nRow, 2) = arrItems(i - 1)
　　　　End If
　　Next i
On Error GoTo 0
　　oDict.RemoveAll
　　Erase arrKeys(), arrItems()

　　For i = nRow + 1 To tnRows
　　　　mtxPrt(i, 1) = ""
　　　　mtxPrt(i, 2) = ""
　　Next i

　　重複リスト = mtxPrt()
　　Erase mtxPrt()
End Function

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

お礼

まだまだVBAは初心者なので、入力しながら理解してみます。
ありがとうございましたm（_ _）m

回答No.3

cj_mover

こんにちは。お邪魔します。

ＶＢＡで考えてみたのですけれど、
ユーザー定義関数（ＵＤＦ）がお奨めです。

ワークシートで使う時は、
　１）リストを作成する範囲全体（H4:J14）を選択
　２）そのまま普通に数式を入力
　　=重複リスト(B4:F6)
　３）Ctrl + Shift + Enter で確定
　　→　{=重複リスト(B4:F6)}　と表示される
のように設定します。
　B4:F6に変更があった時だけ再計算する
　計算回数、１回（２２回ではない）で負荷が少ない
　揮発関数ではないのでブックを開くだけで未保存にはならない
　リスト全体で数式を確定するので不整合に陥り難い
などの特長があります。
短所としては
　リストの一部を変更できない
　リストをリサイズする場合はリスト全体を一旦消去してやり直し
などです。
使い慣れてくると特徴がわかってくると思います。

ＶＢＡでいうと、Worksheet_Change イベントで
シート全体の値変更を常時監視しておいて、
再計算対象範囲に変更があった時だけ処理、
という方法でも可能なのですが、
ここまで形の決まった処理にしては、無駄が多いように思うので、
諸々軽くする意味でユーザー定義関数を提案しています。

ＶＢＡ側からワークシートに
リスト全体を配列として返してやると
ワークシートには自動で各セルに値を仕分ける機能があるので
一発でリスト表示になる、
という一種の配列数式です。「軽い」配列数式です。

ユーザー定義関数の中身自体は初級～中級程度のものなので
編集を加えられる人は多いと思います。
認知度が意外に低い手法かもしれないので、
もし将来変更が必要で質問するようなことになったら、
このＱＡスレッドを参照するようにしてみてください。

以下、標準モジュールに過不足なく貼り付け

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Option Explicit ' cj8090042
Private oDict As Object

Function 重複リスト(範囲 As Range)
　　Dim mtxSrc() ' 元データ[二次元配列]
　　Dim mtxPrt() ' 出力データ[二次元配列]
　　Dim arrKeys() ' キー[一次元配列]
　　Dim arrItems() ' キーをカウントした数[一次元配列]
　　Dim v ' ループ用
　　Dim tnRows As Long ' 呼び出し側セル範囲の行数
　　Dim nRow As Long ' 出力行位置
　　Dim i As Long ' ループ用

　　mtxSrc() = 範囲.Value
　　tnRows = Application.Caller.Rows.Count

　　If oDict Is Nothing Then Set oDict = CreateObject("Scripting.Dictionary")
　　For Each v In mtxSrc()
　　' ' 重複を除いたキーを作成しながら、キーの数をItemとしてカウント
　　　　oDict(v) = oDict(v) + 1
　　Next
　　Erase mtxSrc()

　　arrKeys() = oDict.Keys
　　arrItems() = oDict.Items

　　ReDim mtxPrt(1 To tnRows, 1 To 2)
　　For i = 1 To oDict.Count
　　　　If arrItems(i - 1) > 1 Then
　　　　　　nRow = nRow + 1
　　　　　　mtxPrt(nRow, 1) = arrKeys(i - 1)
　　　　　　mtxPrt(nRow, 2) = arrItems(i - 1)
　　　　End If
　　Next i
　　oDict.RemoveAll
　　Erase arrKeys(), arrItems()

　　For i = nRow + 1 To tnRows
　　　　mtxPrt(i, 1) = ""
　　　　mtxPrt(i, 2) = ""
　　Next i

　　重複リスト = mtxPrt()
　　Erase mtxPrt()
End Function

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

回答No.2

tom04

こんにちは！
VBAになってしまいますが、一例です。

Sheetのレイアウトはアップされている配置通りとします。
画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストし、データ範囲を範囲指定（←必須です）しマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub SAmple1() 'この行から
Dim i As Long, c As Range, r As Range, cnt As Long
i = Cells(Rows.Count, "H").End(xlUp).Row
If i > 3 Then
Range(Cells(4, "H"), Cells(i, "I")).ClearContents
End If
For Each c In Selection
cnt = WorksheetFunction.CountIf(Selection, c)
Set r = Range("H:H").Find(what:=c, LookIn:=xlValues, lookat:=xlWhole)
If r Is Nothing And cnt > 1 Then
With Cells(Rows.Count, "H").End(xlUp).Offset(1)
.Value = c
.Offset(, 1) = cnt
End With
End If
Next c
End Sub 'この行まで

※　最初に書いたように必ず範囲指定した後にマクロを実行してください。
※　No.1さんが回答されていらっしゃるように作業用の列を設ければ当然関数で対応できますが、
今回は一気にやってみました。m（_ _）m

お礼

丁寧にVBAでの解答ありがとうございます。
まだまだVBAは初心者なので、入力しながら理解してみます。
ありがとうございましたm（_ _）m