エクセル：関数について（抽出）

質問

色と数値が入った表があります。
色の隣りのセルに数値が入っています。
別な場所に、「赤」の数値だけを抽出する方法を教えて下さい。
「色」はランダムに入力されています。
VLOOKUPかなと思ったのですが、「色」が一つの列に入っていないとダメですよね。
至急回答いただきたいです。よろしくお願いします。

回答No.6

KenKen_SP · ベストアンサー

とりあえず書いてみました。

「抽出件数が複数ある」とのことでしたから、関数として作成することは不可能（配列で返すようにすれば可能ですが）です。したがって、抽出したデータを任意のセルに書き出す仕様になりました。

ユーザーが範囲指定できるようになっていますので、割と長いコードになってしまいました。一つ一つのコードの説明はご勘弁を。

【機能】
指定したセル範囲内でキーワード検索を行い、“一致したセル”と“ひとつ横セルの値”を任意の場所に書き出します。キーワードにはワイルドカードが使えます。

【手順】
1.　[Alt]+[F11]でVisual Basic Editor起動（以下VBE）
2.　VBE画面で[挿入]-[標準モジュール]クリック
3.　2.で開いたウインドウに下記VBAコードをコピー＆ペースト
4.　VBEを閉じる
5.　[ツール]-[マクロ]-[マクロ]で実行

【以下VBAコード：場所＝標準モジュール】（次行からおわりまで）

Sub Sample()

　　Const RowOffset = 0 '行方向
　　Const ColOffset = 1 '列方向

　　Dim TargetArea As Range, rngCurrent As Range, TargetCell As Range
　　Dim strKeyword As String
　　Dim Buf()
　　Dim i As Long, lngRow As Long, lngCol As Long

　　'検索範囲指定
　　On Error Resume Next
　　　　Set TargetArea = Application.InputBox( _
　　　　"・マウスでドラッグしてセルを選択して下さい" & vbCrLf & _
　　　　"・離れた範囲を選択する場合は、[Ctrl]キーを使います", _
　　　　"検索範囲指定", Type:=8)
　　　　If TargetArea Is Nothing Then Exit Sub
　　On Error GoTo 0
　　Sheets(TargetArea.Parent.Name).Activate
　　TargetArea.Select

　　'検索キーワード指定
　　strKeyword = Application.InputBox( _
　　　　"・直接入力するか、セルを参照して下さい" & vbCrLf & _
　　　　"・ワイルドカードも使えます", _
　　　　"検索キーワード指定", Type:=2)
　　If strKeyword = "False" Then Exit Sub

　　'キーワード検索
　　ReDim Buf(1, 0)
　　i = 1
　　For Each rngCurrent In TargetArea
　　　　With rngCurrent
　　　　　　If .Value Like strKeyword Then
　　　　　　　　'一致した場合OFFSETさせたセルの値を配列にプール
　　　　　　　　ReDim Preserve Buf(1, i)
　　　　　　　　Buf(0, i) = .Value
　　　　　　　　Buf(1, i) = .Offset(RowOffset, ColOffset).Value
　　　　　　　　i = i + 1
　　　　　　End If
　　　　End With
　　Next rngCurrent

　　'結果データ有無のチェック
　　If UBound(Buf, 2) = 0 Then
　　　　MsgBox "指定されたキーワードはありません", vbInformation, "検索結果"
　　　　Exit Sub
　　End If

　　'出力先指定
　　On Error Resume Next
　　　　Set TargetCell = Application.InputBox( _
　　　　　　"貼り付け先セルをひとつ選択して下さい" & vbCrLf & _
　　　　　　"注意）既にデータがある場合、上書きされます", _
　　　　　　i - 1 & "件抽出しました", Type:=8)
　　　　If TargetCell Is Nothing Then
　　　　　　Exit Sub
　　　　End If
　　On Error GoTo 0

　　'出力
　　Sheets(TargetCell.Parent.Name).Activate
　　lngRow = TargetCell.Row: lngCol = TargetCell.Column
　　Application.ScreenUpdating = False
　　With Sheets(TargetCell.Parent.Name)
　　　　For i = 1 To UBound(Buf, 2)
　　　　　　.Cells(lngRow + i - 1, lngCol).Value = Buf(0, i)
　　　　　　.Cells(lngRow + i - 1, lngCol + 1).Value = Buf(1, i)
　　　　Next i
　　End With
　　Application.ScreenUpdating = True

End Sub

回答No.7

KenKen_SP

＞それから、VBAについて勉強するにはどうしたらよいでしょうか？
＞初歩知識しかない私には、かなり難しいでしょうか？

私は人に勉強の仕方を教えられるほどの者ではありませんが、ご参考までに私のVBA学習方法をご紹介します。

1.　マクロの自動記録をとる
2.　1.で自動生成されたコードの意味をヘルプやWEBで調べる
3.　分からないことを掲示版で質問する

これを繰り返していたら、ある程度マクロというものが理解できました。

次に、WEB上の様々なサンプルコードが存在しますが、これと同等のことを自分でコーディングしてみて、比較します。これが大変勉強になっています。

お礼

ご返答大変遅くなり申し訳ありません。
何度も回答いただき感謝しております。
大変参考になりました。ありがとうございました。

回答No.5

KenKen_SP

＞いえいえ、たぶん間違ってないと思います。

そう言っていただけるとありがたいです。

＞赤の場合の数値だけを抽出、黄色の場合・・・青、白等

#1で書きました理由によりVBAで行うしかありません。できなくはないです。補足いただけましたら、コードを書いてみます。

1.　赤の場合、とはセル背景色ですか、文字色ですか？
2.　抽出したデータについて
　　--＞複数件抽出される可能性は？
　　--＞抽出結果は新規シートに書き出し？
3.　「色の隣りのセルに数値」
　　--＞これは OFFSET を利用することで可能です。
　　--＞右方向に1つ隣ということでよろしいですか？
4.　抽出する範囲は固定ですか？それとも指定できた方がいいですか？

補足

本当にご親切にありがとうございます。

1.赤の場合とは、
背景色でも文字色でもなく、任意の文字です。
ＡやＡ´、Ｂ、Ｃ・・・。この分類はまだ未確定なので、例として赤、青、としてしまったのですが、これがそもそもの間違いでした。スミマセン。。りんごやバナナにしておけば・・・(・_*)＼

2.抽出データについて、
・複数件抽出の可能性ありです。
・新規シートに書き出す場合と、同一シートの場合があります。

3.色の隣りのセルに数値・右方向に一つ隣です。

4.抽出する範囲・指定できた方が良いです。

何度も申し訳ありません。
本当に心強いです。ありがとうございます。

それから、VBAについて勉強するにはどうしたらよいでしょうか？
コード作成についてまで書いてある本はあまり見かけません。
初歩知識しかない私には、かなり難しいでしょうか？

ｇｏｏで皆さんにいろいろ教えて頂きながら少しずつ知識を得ているって感じで、本当に感謝です。

回答No.4

KenKen_SP

#1、#2です。

、、、私は少し寝ぼけているみたいです。

ご質問主様の意図を全く勘違いしてました。申し訳ありません。#1、#2は無視して下さい。

お礼

いえいえ、たぶん間違ってないと思います。
赤の場合の数値だけを抽出、黄色の場合・・・青、白等など。なのです。
私の質問の仕方がマギラワシイ＆分かりづらいのです。
色なんかを例にあげるからですよね。。。

貼付してやってみましたが、分かりませんでしたm(__)m

ＶＢＥのコードを教えて頂くとなると、実際の表を詳細にご説明しなくては無理ですよね。

どのコードがどこを差しているか、分かれば応用もきくのですが、さっぱりわかりません。

もう少し具体的に質問し直します。
またその際には宜しくお願いします。
ご丁寧にありがとうございました。

KenKen_SPさん、at121さん、ありがとうございました。

回答No.3

at121

シート内の　「赤数字」のセルを
別な場所　？　選択中の　セルの下：縦列　に　コピー

↓マクロ　vbエディタ　標準モジュールに貼る↓

Sub 赤数値のセルを選択したセルの下に縦コピー()
Dim 該当するセル As Range

On Error GoTo 終了
For Each i In Cells.SpecialCells(xlCellTypeConstants, xlNumbers) '数字
If i.Font.ColorIndex = 3 Then '赤.Font.字？　背景.Interior.赤？
If 該当するセル Is Nothing Then
Set 該当するセル = i
Else
Set 該当するセル = Range(該当するセル.Address & "," & i.Address)
End If
End If
Next i

Set 転送先 = Cells(Selection.Row, Selection.Column)

For Each i In 該当するセル
i.Copy (転送先)
Set 転送先 = 転送先.Offset(1, 0)
Next i

回答No.2

KenKen_SP

すみません。VBAコードを差し替えさせて下さい。一応#1のものでも大丈夫なんですが、投稿した後で、「別に無理に集計する必要はないなぁ」と我に返りました。

機能的には指定したセル範囲で赤色のセルを探し、最初に見つかったセルのデータを返します。複数の同一色セルは無視されます。セル検索は横方向に検索していきます。
例えば、A1:C3なら A1--＞C1、A2--＞C2、A3--＞C3の順番です。

基本的な使い方は#1とほぼ同様ですが、関数名を変更しましたので、

= セル色抽出(A1:C10,3,0,1)

こうなります。抽出するデータは文字列でも、数値でもOKです。

重要なことを忘れていました。セルの色を変えただけでは関数は再計算してくれません（不可能です）ので、その場合には手動で再計算を行って下さい。

【以下VBAコード：場所＝標準モジュール】

Function セル色抽出(セル範囲 As Range, カラー番号 As Long, _
　　Optional 行オフセット As Long = 0, _
　　Optional 列オフセット As Long = 0)
　　For Each rngCurrent In セル範囲
　　　　If カラー番号 = rngCurrent.Interior.ColorIndex Then
　　　　　　セル色抽出 = rngCurrent.Offset(行オフセット, 列オフセット).Value
　　　　　　Exit For
　　　　End If
　　Next rngCurrent
End Function

回答No.1

KenKen_SP

＞VLOOKUPかなと思ったのですが、「色」が一つの列に入っていないとダメですよね。

EXCELの標準関数は、原則としてセル書式（背景色、罫線、文字色、フォントなど）を引数に使えません。これは、「赤色のセルだけ計算する」といった

「セル書式を以って、何らかの計算させることは不可能」

ということです。そこで、解決策としては

1.　EXCEL4.0マクロ関数＋作業列
2.　VBAユーザー定義関数

のいづれかを用いることになります。以下にVBAユーザー定義関数のサンプルを示します。

【使い方】
通常のワークシート関数のように使います。

= ColorSum(A1:C10,3,0,1)

第2引数でカラー番号を指定しますが、[赤]＝3です。
第3、4引数でその色のセルからのオフセット値を指定します。

ex) 赤色のセル1行下なら = ColorSum(A1:C10,3,1,0)
ex) 赤色のセル1列右なら = ColorSum(A1:C10,3,0,1)

これで、赤色セルの右側の数字を抽出できます。ただし、第1引数で指定した範囲に同じ色があった場合、合計を返します。VLOOKUP関数のように使うなら、同じ範囲で色が重複しないようにして下さい。

【以下VBAコード：場所＝標準モジュール】

Function ColorSum(セル範囲 As Range, カラー番号 As Long, _
　　Optional 行オフセット As Long = 0, _
　　Optional 列オフセット As Long = 0)

　　Dim Result
　　For Each rngCurrent In セル範囲
　　　　If カラー番号 = rngCurrent.Interior.ColorIndex Then
　　　　　　With rngCurrent.Offset(行オフセット, 列オフセット)
　　　　　　　　If IsNumeric(.Value) Then
　　　　　　　　　　Result = Result + .Value
　　　　　　　　End If
　　　　　　End With
　　　　End If
　　Next rngCurrent
　　ColorSum = Result

End Function