[[20161229180847]]　『血液検査結果』（還暦直前）　ページの最後に飛ぶ

『血液検査結果』（還暦直前）

 Sheet1に血液検査の基準範囲です。
 Sheet2には血液検査の測定値です。
 測定値が基準範囲を超えたとき、エラーメッセージを出し、その基準範囲
 の下限、上限の値もメッセージに入れたいと思っています。
 例えば、ASTが基準範囲を超えた場合、「ASTの値が基準値から外れてい
 ます。基準値は8～40です」
 すべての項目が正常値であれば「以上ありませんでした」
 マクロボタン（チェック開始ボタン）を押すとマクロが開始し上記のメ
 ッセージが出るマクロをご教示お願い致します。

 Sheet1
    A       B         C
 1         下限　　　上限
 2 AST　　  8         40
 3 ALT      4         45            
 4 AL-P   100        340   
 5 ɤ-GTP              35

 Sheet2
    A       B
 1        測定値
 2 AST     42    
 3 ALT     14
 4 AL-P   350
 5 ɤ-GTP   20

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

 いったん、アップ済みの回答を削除します。

 再掲します。
なお、両方のシートの項目が並び順も含手目全く同じなら、コードはもっとシンプルになります。

 Sub Sample()
    Dim c As Range
    Dim x As Long
    Dim s As String
    Dim z As Variant
    Dim r As Range
    Dim mn As Variant
    Dim mx As Variant

    With Sheets("Sheet1")
        Set r = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With

    With Sheets("Sheet2")
        With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            ReDim ans(1 To .Rows.Count)
            For Each c In .Columns(1).Cells
                x = x + 1
                z = Application.Match(c, r, 0)
                If IsNumeric(z) Then
                    mn = r.Cells(z).Offset(, 1).Value
                    mx = r.Cells(z).Offset(, 2).Value
                    If c.Offset(, 1).Value >= mn And c.Offset(, 1).Value <= mx Then
                        s = " : 正常値です"
                    Else
                        s = " : 異常値です。正常値範囲は " & mn & " ～ " & mx & " です。"
                    End If
                Else
                    s = " : 判定不能"
                End If
                ans(x) = c.Value & s
            Next
        End With
    End With

    MsgBox "判定結果は以下の通りです" & vbLf & Join(ans, vbLf)

 End Sub

（β） 2016/12/29(木) 19:10

 βさん、ありがとうございます。
 希望そのものです。素晴らしいです。

 両方のシートの項目の並びは同じで変わることはありません。
（還暦直前） 2016/12/29(木) 20:11

 もし、両方のシートともに 10項目とか、20項目とか、まったく同じで、並ぶ順も同じなら。

 Sub Sample2()
    Dim c As Range
    Dim x As Long
    Dim s As String
    Dim mn As Variant
    Dim mx As Variant

    With Sheets("Sheet2")
        With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            ReDim ans(1 To .Rows.Count)
            For Each c In .Columns(1).Cells
                x = x + 1
                mn = Sheets("Sheet1").Range(c.Address).Offset(, 1).Value
                mx = Sheets("Sheet1").Range(c.Address).Offset(, 2).Value
                If c.Offset(, 1).Value >= mn And c.Offset(, 1).Value <= mx Then
                    s = " : 正常値です"
                Else
                    s = " : 異常値です。正常値範囲は " & mn & " ～ " & mx & " です。"
                End If
                ans(x) = c.Value & s
            Next
        End With
    End With

    MsgBox "判定結果は以下の通りです" & vbLf & Join(ans, vbLf)

 End Sub

（β） 2016/12/29(木) 20:31

 βさん勉強になります。
 年末お忙しい中、ありがとうございました。
（還暦直前） 2016/12/29(木) 21:17

Sub main()
'下限のみ設定されている場合の対応

    Dim r As Range, c As Range, flg As Boolean
    For Each c In Sheets("Sheet2").Range("B:B").SpecialCells(2, 1)
        Set r = Sheets("Sheet1").Cells.Find(What:=c.Offset(, -1).Value, LookAt:=xlWhole)
        If Not r Is Nothing Then
            If Val(c.Value) - Val(r.Offset(, 1).Value) < 0 Or IIf(r.Offset(, 2).Value = "", Val(c.Value), r.Offset(, 2).Value) - Val(c.Value) < 0 Then
                MsgBox c.Offset(, -1).Value & "の値が基準値から外れています。基準値は" & r.Offset(, 1).Value & "～" & r.Offset(, 2).Value & "です。"
                flg = True
            End If
        End If
    Next c
    If Not flg Then MsgBox "異常ありませんでした。"
End Sub
（mm） 2016/12/30(金) 10:08

 βさん、mmさんありがとうございます。
 参考にさせていただきます。

 さらに年齢の条件を増やして、レイアウトも変更しての質問良いでし
 ょう か？
 新規にアップしなおした方がよいでしょうか？
（還暦直前） 2016/12/30(金) 18:08

 継続でも新規でもいいですよ。

（β） 2016/12/30(金) 18:09

 βさん、追加質問、快く受けていただき感謝です。ありがとうございます。

 Sheet2のB1に年齢を、Sheet2のAB列には年齢範囲を表しています。
 下記表では、年齢が18歳なので、Sheet1の5行目を見に行き、前回同様に
 測定値が基準範囲を超えたとき、エラーメッセージを出し、その基準範囲
 の下限、上限の値もメッセージに入れたいです。
 申し訳ありませんが、ご教示お願い致します。

 Sheet1

    A     B      C     D        E    F       G　　H　　   I    J     
 1   年齢          AST           ALT　　      AL-P　       ɤ-GTP　
 2      　　　 下限   上限   下限   上限   下限  上限   下限 上限
 3　5　　10      8　　 40     4      45    100    340         35
 4 11    15      9     42     5      47    120    350         36 
 5 16    20     12     45     7      50    130    360         37
 6 21    25     15     50    10      53    140    370         40

 Sheet2
    A　　　  B
 1  年齢    18
 2  AST      7
 3  ALT     14
 4 AL-P      1
 5 ɤ-GTP    20

（還暦直前） 2016/12/30(金) 19:02

 βさんの回答なは何も不満はなく、思いどおりのもので、満足しています。
 今回は年齢を加えたかったので、Sheet2は前回の項目が一行下にズレ、Sheet1では年齢範囲を追加しよう
 と思うと、 横書きのほうが、わかりやすいと感じたので変更させていただきました。

（還暦直前） 2016/12/30(金) 19:50

 コード、いそいで書いたので、もう少し整理もできるかと思いますが。

 以下の前提です。

 ・Sheet1 の年齢幅は昇順になっている。
 ・Sheet1 の１行目の検査項目の数と並びは、Sheet2のA列のそれと、完全に一致する。
 ・mmさんから、下限のみ設定の対応処理が提示されましたが、検査項目の性格上、上限の見はあっても下限のみはありえない。

 Sub Sample3()
    Dim myAge As Long
    Dim mnAge As Long
    Dim mxAge As Long
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim myRow As Long
    Dim i As Long
    Dim j As Long
    Dim x As Long
    Dim mn As Variant
    Dim mx As Variant
    Dim myData As Variant
    Dim s As String

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")

    myAge = sh2.Range("B1").Value
    mnAge = sh1.Range("A3").Value
    mxAge = sh1.Range("B" & Rows.Count).End(xlUp).Value
    ReDim ans(1 To sh2.Range("A" & Rows.Count).End(xlUp).Row - 1)

    If myAge < mnAge Or myAge > mxAge Then
        MsgBox myAge & "才の被験者に対する情報はありません"
        Exit Sub
    End If
    'Sheet1の年齢が当てはまるSheet2の行を取得
    myRow = WorksheetFunction.Match(myAge, sh1.Range("A3", sh1.Range("A" & Rows.Count).End(xlUp)), 1) + 2
    i = 2   'SHeet2のデータ行
    For j = 3 To sh1.Cells(1, Columns.Count).End(xlToLeft).Column Step 2    'Sheet1 の検査項目
        x = x + 1
        mn = sh1.Cells(myRow, j).Value
        mx = sh1.Cells(myRow, j + 1).Value
        myData = sh2.Cells(i, "B").Value
        If myData >= mn And myData <= mx Then
            s = " : 正常値です"
        Else
            s = " : 異常値です。正常値範囲は " & mn & " ～ " & mx & " です。"
        End If
        ans(x) = sh2.Cells(i, "A").Value & "(" & myData & ")" & s
        i = i + 1
    Next

    MsgBox "判定結果は以下の通りです" & vbLf & Join(ans, vbLf)

 End Sub

（β） 2016/12/30(金) 20:14

 βさん、すべて確認し、うまくいきました。
 いたらなかった点、お詫び致します。
 ありがとうございました。

（還暦直前） 2016/12/30(金) 21:42

 βさん、変数にmnAge mxAgeとか、mn mxと書かれていますが、minとは書かずmn 、maxはmxと書いて
 おられるのは何故ですか？何か決まり事があるのでしょうか？

（還暦直前） 2017/01/07(土) 00:08

遅ればせながら。。。

＞測定値が基準範囲を超えたとき、エラーメッセージを出し、その基準範囲
＞の下限、上限の値もメッセージに入れたいと思っています。

メッセージボックスだと、マクロを実行したときしか、
判定結果が解らなくないですか？

セルに結果を書き出したり、
基準範囲からはみ出た数値のセルに色を付けるなりしたら、
いかがでしょうか？

（まっつわん） 2017/01/07(土) 08:28

 >>何か決まり事があるのでしょうか？

 maxAge や　minAge は、まったく問題ありません。　別途、mx や mn という変数名を規定しましたので
 それと合わせるために mxAge,mnAge にしてあります。

 で、max や min。
 こう書いても、実行上、支障はありません。

 でも、これらは　シート関数の関数名ですね。
 以下を新規ブックの標準モジュールに貼り付けてみてください。

 Sub Test()
    Dim max As Long

    MsgBox WorksheetFunction.Max(Range("A1:A10"))

 End Sub

 貼り付けた結果、よ～く見てください。どこか、変化してますでしょ？
 Max となるべきとろこ、 max になっちゃってますね。

 よく row なんて変数を書いている人が、こうなった！！　と大騒ぎして、エクセルを再インストールしなきゃいけないか！！
 といった質問がでることもあります。

 エクセルやVBA で定められた関数名やメソッド名、プロパティ名等は、変数として使わないほうが
 よろしいかと思いますね。

（β） 2017/01/07(土) 09:04

 βさん、よくわかりました。
 ありがとうございました。
（還暦直前） 2017/01/09(月) 22:58

 βさん、二週間前にアップしたもので申し訳ありませんが、指導よろしくお願いします。
 正常値の時は何も表示せず、異常値の時だけ、前記とメッセージが出るようにしたいです。
 ASTが基準範囲を超えた場合、「ASTの値が基準値から外れています。基準値は8～40です」
 よろしくお願いします。

（還暦直前） 2017/01/11(水) 20:05

 現在、正常、異常　ともに　配列に格納していますが、これを　異常値の場合のみ格納するように変更すればいいのですよ。

 Sub Sample3()
    Dim myAge As Long
    Dim mnAge As Long
    Dim mxAge As Long
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim myRow As Long
    Dim i As Long
    Dim j As Long
    Dim x As Long
    Dim mn As Variant
    Dim mx As Variant
    Dim myData As Variant

    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")

    myAge = sh2.Range("B1").Value
    mnAge = sh1.Range("A3").Value
    mxAge = sh1.Range("B" & Rows.Count).End(xlUp).Value
    ReDim ans(1 To sh2.Range("A" & Rows.Count).End(xlUp).Row - 1)

    If myAge < mnAge Or myAge > mxAge Then
        MsgBox myAge & "才の被験者に対する情報はありません"
        Exit Sub
    End If
    'Sheet1の年齢が当てはまるSheet2の行を取得
    myRow = WorksheetFunction.Match(myAge, sh1.Range("A3", sh1.Range("A" & Rows.Count).End(xlUp)), 1) + 2
    i = 2   'SHeet2のデータ行
    For j = 3 To sh1.Cells(1, Columns.Count).End(xlToLeft).Column Step 2    'Sheet1 の検査項目
        mn = sh1.Cells(myRow, j).Value
        mx = sh1.Cells(myRow, j + 1).Value
        myData = sh2.Cells(i, "B").Value
        If myData < mn Or myData > mx Then
            x = x + 1
            ans(x) = sh2.Cells(i, "A").Value & "の値が基準値からはずれています。基準値は" & mn & "～" & mx & "です。"
        End If
        i = i + 1
    Next

    If x = 0 Then
        MsgBox "判定結果はすべて正常値の範囲内でした。"
    Else
        ReDim Preserve ans(1 To x)
        MsgBox "判定結果は以下の通りです" & vbLf & Join(ans, vbLf)
    End If

 End Sub

（β） 2017/01/11(水) 20:50

 βさん、 現在、正常、異常　ともに　配列に格納していますが、これを　
 異常値の場合のみ格納するように変更すればいい。わかりました。
 ありがとうございました。
（還暦直前） 2017/01/11(水) 21:32

コメント返信：

[ 一覧(最新更新順) ]

[[20161229180847]] 『血液検査結果』（還暦直前） ページの最後に飛ぶ

[[20161229180847]]　『血液検査結果』（還暦直前）　ページの最後に飛ぶ