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

Question

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

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

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

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

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

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

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

web2525 · Accepted Answer

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

mitarashi · Answer

#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

tom04 · Answer

こんばんは！
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

kagakusuki · Answer

　マクロではマクロの実行を指示する操作が必要となり、配列変数では「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)の「基準値に最も近い値」が入力されているセルが赤く塗りつぶされます。

web2525 · Answer

No1です

差分の絶対値は

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

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

で求められます

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

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

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

mitarashi · Answer

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

'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

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

#2です。

こんばんは！

マクロではマクロの実行を指示する操作が必要となり、配列変数では「Sift+Ctrl+Enterで確定」という操作を必要としますが、関数を使えばセルに値を入力するだけで自動的に値を求める事が出来ます。

No1です

最小値と、縦、横のアドレスを変数に保持しておいて、ループを回し、引き算して、絶対値を取って、全部比較するしかないのではないでしょうか。

質問内容だと24900（E11セル）も差は100ですが

この回答への補足

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

　マクロではマクロの実行を指示する操作が必要となり、配列変数では「Sift+Ctrl+Enterで確定」という操作を必要としますが、関数を使えばセルに値を入力するだけで自動的に値を求める事が出来ます。