エクセルでの表検索＆比較です。

質問

図１のような表があります。

やりたいことは次の(1)～(3)です。

(1)　黄色の部分に適当な数字を入力します。（今仮に２５０００とします。この部分は変数です。）
(2)　図１の表の中から最も近い値を緑の部分に表示するとともに、その数字のセルを赤でマークします。（行６－列７の２５１００になります）
(3)　(1)と(2)の差をピンクの部分に表示します。（絶対値で）（１００になります）

これを自動でやりたいのですがどうしてもできません。

関数や、テーブル検索のプログラムでもかまいませんので、ご存知の方どうかお知恵をお貸しください。

これができると、大変助かります。

よろしくお願いいたします。

回答No.1

web2525 · ベストアンサー

質問内容だと24900（E11セル）も差は100ですが
検索値以下の近似値は必要ないのか？
（必要ない場合：検索値以上の差分が200で、検索値以下の差分が100の場合は？）

お礼

回答ありがとうございます。

今回は、全員の方をベストアンサーとさせて頂きたいのですが、１人しか選べませんので、先着順によりｗｅｂ２５２５様をベストアンサーとさせていただきます。

すばらしい回答をありがとうございました。

補足

鋭い、ご指摘ありがとうございます。

２４９００も必要です。

このような漏れを防ぎたいのです。

例で言えば上下関係なく、２５０００の近似値を求めたいのです。

よろしくお願いいたします。

回答No.6

mitarashi

#2です。
#3さんの回答をを見て気付きましたが、どうせ配列数式を使っているのだから、引き算もそこでやれば良いのですね。
そこを簡略化して、複数該当の場合は列挙する様に改善したものを、一応投稿しておきます。
（回さないと言ったループを結局回さざるをえませんが．．．）
Sub test()
Dim srcRange As Range, calcRange As Range
Dim difValue As Double
Dim refRange As Range, hitRange As Range
Dim firstAddress As String
Dim counter As Long

Sheets("Sheet1").UsedRange.Cells.Interior.ColorIndex = xlNone
Sheets("Sheet2").Cells.Clear
'A1を対象セル範囲の左上セルの番地に変更のこと
With Sheets("Sheet1")
Set srcRange = .Range(.Range("A1"), .Range("A1").End(xlDown).End(xlToRight))
End With
Set calcRange = Sheets("Sheet2").Range(srcRange.Address)
'比較する数値の入ったセル
Set refRange = Sheets("Sheet1").Range("I1")
refRange.Offset(2, 0).CurrentRegion.Cells.ClearContents
refRange.Offset(4#).Cells.ClearContents
calcRange.FormulaArray = "=ABS(" & srcRange.Parent.Name & "!" & srcRange.Address(True, True) & " - " & CStr(refRange.Value) & ")"
'再計算防止のため値に変換
calcRange.Value = calcRange.Value
difValue = Application.WorksheetFunction.Min(Sheets("Sheet2").Range(srcRange.Address))
Set hitRange = calcRange.Find(difValue, LookIn:=xlValues, lookat:=xlWhole)
counter = 0
If Not hitRange Is Nothing Then
firstAddress = hitRange.Address
Do
Sheets("Sheet1").Range(hitRange.Address).Interior.Color = vbRed
Do
If refRange.Offset(2, counter).Value = "" Then
refRange.Offset(2, counter).Value = Sheets("Sheet1").Range(hitRange.Address).Value
Exit Do
End If
counter = counter + 1
Loop
Set hitRange = calcRange.FindNext(hitRange)
Loop While Not hitRange Is Nothing And hitRange.Address <> firstAddress
End If
refRange.Offset(4, 0).Value = difValue
End Sub

お礼

回答ありがとうございます。

今回は、全員の方をベストアンサーとさせて頂きたいのですが、１人しか選べませんので、先着順によりｗｅｂ２５２５様をベストアンサーとさせていただきます。

すばらしい回答をありがとうございました。

回答No.5

tom04

こんばんは！
VBAでの一例です。

お示しの配置とは異なりますが、↓の画像通りとします。

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
下のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample() 'この行から
Dim c As Range, endRow As Long, cnt As Long, vL, myArea As Range
Set myArea = Range("C3:L12") '←セル範囲は適宜合わせてください。
endRow = Cells(Rows.Count, "O").End(xlUp).Row
If endRow > 1 Then
Range(Cells(2, "O"), Cells(endRow, "O")).ClearContents
End If
Range("P2") = ""
myArea.Interior.ColorIndex = xlNone
For Each c In myArea
vL = Abs(Range("N2") - c)
If Range("P2") = "" Then
Range("P2") = vL
ElseIf vL < Range("P2") Then
Range("P2") = vL
End If
Next c
cnt = 1
For Each c In myArea
If c = Range("N2") + Range("P2") Or c = Range("N2") - Range("P2") Then
cnt = cnt + 1
Cells(cnt, "O") = c
c.Interior.ColorIndex = 3
End If
Next c
End Sub 'この行まで

※　画像では一桁少なくデータを作成しています。
※　関数でないのでデータ変更があるたびにマクロを実行する必要があります。
※　必ずN2セルに検索値を入力してマクロを実行してください。m(_ _)m

お礼

回答ありがとうございます。

今回は、全員の方をベストアンサーとさせて頂きたいのですが、１人しか選べませんので、先着順によりｗｅｂ２５２５様をベストアンサーとさせていただきます。

すばらしい回答をありがとうございました。

回答No.4

kagakusuki

マクロではマクロの実行を指示する操作が必要となり、配列変数では「Sift+Ctrl+Enterで確定」という操作を必要としますが、関数を使えばセルに値を入力するだけで自動的に値を求める事が出来ます。（工夫すればマクロや配列変数でも全自動で値を求める様にする事も出来ない訳では無い筈なのですが、ここまでの回答の中にあるものは、マクロや配列式を自動化させたものではない様です）

　尚、

>２４９００も必要です。

>このような漏れを防ぎたいのです。

という話ですので、(2)の緑のセルを上下に並べた2箇所に増やして、(3)のピンクのセルの位置を1つ下の方にずらす事にします。
　それから、御質問欄に添付されている画像では、写っている各セルのセル番号が不明ですので、今仮に、表が設けられているセル範囲がA2～L13（データが入っているのはA3セルとB2セル、及び「B3～L13の範囲からB3セルを除外した範囲」）であり、N3セルに(1)の基準となる数値を入力し、N5セルとN6セルに(2)の「基準値に最も近い値」を表示し、N8セルに(3)の「最も近い値と基準値との差」を表示するものとします。

　まず、N8セルに次の関数を入力して下さい。

=IF(AND(ISNUMBER($N$3),COUNT($B$3:$L$13)),MIN(ABS(LARGE($B$3:$L$13,COUNTIF($B$3:$L$13,">"&$N$3)+(COUNTIF($B$3:$L$13,"<="&$N$3)>0))-$N$3),ABS(SMALL($B$3:$L$13,COUNTIF($B$3:$L$13,"<"&$N$3)+(COUNTIF($B$3:$L$13,">="&$N$3)>0))-$N$3)),"")

　次に、N5セルに次の関数を入力して下さい。

=IF(ISNUMBER($N$8),$N$3+$N$8*((COUNTIF($B$3:$L$13,$N$3+$N$8)>0)*2-1))

　次に、N6セルに次の関数を入力して下さい。

=IF(ISNUMBER($N$8),IF(AND(COUNTIF($B$3:$L$13,$N$3-$N$8),$N$5>$N$3),$N$3-$N$8,""),"")

　次に、以下の操作を行って、(2)の「基準値に最も近い値」が入力されているセルの色を変える条件付き書式を設定して下さい。

【ExcelのバージョンがExcel2007以降の場合】

B3セルを選択
　　↓
[ホーム]タブをクリック
　　↓
現れた「スタイル」グループの中にある[条件付き書式]ボタンをクリック
　　↓
現れた選択肢の中にある[ルールの管理]をクリック
　　↓
現れた「条件付き書式ルールの管理」ダイアログボックスの中にある[新規ルール]ボタンをクリック
　　↓
現れた「新しい書式ルール」ダイアログボックスの[数式を使用して、書式設定するセルを決定]をクリック
　　↓
「次の数式を満たす場合に値を書式設定」と記されている欄に次の数式を入力

=AND(COUNT(B3,$N$8)=2,ABS(B3-$N$3)=$N$8)

　　↓
「新しい書式ルール」ダイアログボックスの[書式]ボタンをクリック
　　↓
現れた「セルの書式設定」ダイアログボックスの[塗りつぶし]タブをクリック
　　↓
現れた色のサンプルの中にある赤色の四角形をクリック
　　↓
「セルの書式設定」ダイアログボックスの[OK]ボタンをクリック
　　↓
「新しい書式ルール」ダイアログボックスの[OK]ボタンをクリック
　　↓
「条件付き書式ルールの管理」ダイアログボックスの中にある「ルール(表示順で適用)」欄が「数式:=AND(CO...」となっている行の「適用先」欄をクリック
　　↓
B3～L13のセル範囲をまとめて範囲選択
　　↓
「条件付き書式ルールの管理」ダイアログボックスの中にある[適用]ボタンをクリック
　　↓
「条件付き書式ルールの管理」ダイアログボックスの中にある[OK]ボタンをクリック

【ExcelのバージョンがExcel2007よりも前のものである場合】

B3～L13のセル範囲を纏めて範囲選択
　　↓
[メニュー]バーの[書式]ボタンをクリック
　　↓
現れた選択肢の中にある[条件付き書式]をクリック
　　↓
現れた「条件付き書式の設定」ダイアログボックスの「条件1(1)」の囲いの中にある左端の欄をクリック
　　↓
現れた選択肢の中にある「数式が」をクリック
　　↓
「条件付き書式の設定」ダイアログボックスの「条件1(1)」の囲いの中にある左から2番目の欄に次の数式を入力

=AND(COUNT(B3,$N$8)=2,ABS(B3-$N$3)=$N$8)

　　↓
「条件付き書式の設定」ダイアログボックスの「条件1(1)」の囲いの中にある[書式]ボタンをクリック
　　↓
現れた「セルの書式設定」ダイアログボックスの[パターン]タブをクリック
　　↓
現れた[色]欄の色のサンプルの中から赤色の四角形をクリック
　　↓
「セルの書式設定」ダイアログボックスの[OK]ボタンをクリック
　　↓
「条件付き書式の設定」ダイアログボックスの[OK]ボタンをクリック

　これで、全自動でN8セルに(3)の「最も近い値と基準値との差」が表示され、(2)の「基準値に最も近い値」が上下2つある場合にはN5セルとN6セルに各々の値が表示され、(2)の「基準値に最も近い値」が1つしかない場合にはN5セルにのみ表示され、(2)の「基準値に最も近い値」が入力されているセルが赤く塗りつぶされます。

お礼

回答ありがとうございます。

今回は、全員の方をベストアンサーとさせて頂きたいのですが、１人しか選べませんので、先着順によりｗｅｂ２５２５様をベストアンサーとさせていただきます。

すばらしい回答をありがとうございました。

回答No.3

web2525

No1です

差分の絶対値は

｛=MIN(ABS(N2-B2:L12))｝

※配列計算（Sift+Ctrl+Enterで確定）

で求められます

近似値は
=IF(COUNTIF(B2:L12,N2+N6),N2+N6,N2-N6)

※検索値に差分を足した数値があればその数値を、無い場合は検索値から差分を引いた数値を表示

一覧の色付けは条件付き書式で

お礼

回答ありがとうございます。

今回は、全員の方をベストアンサーとさせて頂きたいのですが、１人しか選べませんので、先着順によりｗｅｂ２５２５様をベストアンサーとさせていただきます。

すばらしい回答をありがとうございました。

回答No.2

mitarashi

最小値と、縦、横のアドレスを変数に保持しておいて、ループを回し、引き算して、絶対値を取って、全部比較するしかないのではないでしょうか。まともな回答は親切な回答者の方にお任せして、ループを回さない方法を試しにやってみました。
手元の簡略化した表でやっていますので、お示しのセル配置とは異なっています。画像をご参照下さい。

'Sheet2と、Sheet3を都度真っ新にするのでご注意下さい
Sub test()
Dim srcRange As Range, dstRange As Range, calcRange As Range
Dim difValue As Double
Dim refRange As Range, hitRange As Range

'対象範囲は簡便のため、Sheet1のA1から入っているとする
'ご質問の表に合わせるにはもっと真面目にやる必要がある
Sheets("Sheet1").UsedRange.Cells.Interior.ColorIndex = xlNone
Sheets("Sheet2").Cells.Clear
Sheets("Sheet3").Cells.Clear
Set srcRange = Sheets("Sheet1").Range("A1").CurrentRegion
srcRange.Copy Sheets("Sheet2").Range("A1")
Set dstRange = Sheets("Sheet2").Range("A1").CurrentRegion
Set calcRange = Sheets("Sheet3").Range(dstRange.Address)
'比較する数値の入ったセル
Set refRange = Sheets("Sheet1").Range("I1")
refRange.Copy
dstRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlSubtract, SkipBlanks:=False, Transpose:=False
calcRange.FormulaArray = "=ABS(Sheet2!" & dstRange.Address(True, True) & ")"
calcRange.Value = calcRange.Value
difValue = Application.WorksheetFunction.Min(Sheets("Sheet3").Range(dstRange.Address))
'手抜きで最初に見つかった一個しか対象にしていません
Set hitRange = calcRange.Find(difValue, LookIn:=xlValues, lookat:=xlWhole)
Sheets("Sheet1").Range(hitRange.Address).Interior.Color = vbRed
refRange.Offset(2, 0).Value = Sheets("Sheet1").Range(hitRange.Address).Value
refRange.Offset(4, 0).Value = difValue
End Sub

お礼

回答ありがとうございます。

今回は、全員の方をベストアンサーとさせて頂きたいのですが、１人しか選べませんので、先着順によりｗｅｂ２５２５様をベストアンサーとさせていただきます。

すばらしい回答をありがとうございました。