1286721481 エクセルについての質問です。得点の集計をしたいのですが、1~15の各項目をチェックすると〇がついて、チェックした欄によって、右下に得点の合計を出したいのですが、やり方が分かりません。ちなみに、チェックする項目によっても、点数は0~3点と異なります。エクセルのバージョンは2007です。説明だけでは、解らないと思うので、画像を参照して下さい。宜しくお願いします。

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2010/10/10 23:38:04
  • 終了:2010/10/17 23:40:02

ベストアンサー

id:Silvanus No.4

Silvanus回答回数174ベストアンサー獲得回数672010/10/14 10:31:06

ポイント24pt

プルダウン式はお気に召さなかったのでしょうか(汗)。

…あるいは、単にコメントに気付かれなかったのかも知れませんが。

ということで、こんな感じでいかがでしょうか。

http://rct3jp.info/hatena/BDTest.xls

もし、開いた後、スコアシートをクリックした際に「保護されていて変更できない…」と

叱られたら、一旦[校閲]-[シートの保護の解除]を行ない、その後に、

[開発]-[マクロ]から、マクロ"LockScoreSheet"を実行して下さい。

こうすると、患者さんがシートに対して行える操作はクリックのみとなり

シートの内容を勝手に変更できなくなります。

id:suzufumi

Silvanus 様、度々の回答及び作成、誠に有難うございます。

忙しくて、ここ数日はパソコンを開いてませんでした。

私の望んでいた通りの出来映えでした。有難うございます。

ここまで、作って頂いた上で恐縮ですが、作り方(マクロ?)を教えていただけないでしょうか?

似たようなチェックリストを今度は、自分で作ってみたいのです。

回答者制限を緩和しましたので、何卒、宜しくお願いします。

2010/10/16 21:08:20

その他の回答(3件)

id:Silvanus No.1

Silvanus回答回数174ベストアンサー獲得回数672010/10/11 00:05:34

ポイント25pt

こんな感じでいかがでしょうか。

マクロなどは使用しておりません。数式(CountIf関数)のみです。

http://rct3jp.info/hatena/suzufumi_san.xls

各設問には1つだけ○印がついているものとします。

複数個ついているかどうかのチェックは行なっておりません。

必要ならば付けますが…。

id:suzufumi

ありがとうございます。質問の説明不足ですみませんが、〇はチェックボックスのように、

クリックしたら自動で〇が付くようにおねがいします。1つの項目は、必ず1つになるようにして下さい。

間違って、チェックした場合は、改めてチェックしたところだけが〇が付くようにしたいです。

再度宜しくお願いします。

2010/10/11 01:26:57
id:yoneto164 No.2

ヨネちゃん回答回数813ベストアンサー獲得回数942010/10/11 05:01:31

ポイント17pt

オプションボタン

http://ikutawasabi.hp.infoseek.co.jp/xlf0601.htm

とグループボックス

http://ikutawasabi.hp.infoseek.co.jp/xlf0603.htm

を使って作ってみましたが、

http://acappella.cc/test/option_box.xls

15問もあると作るのが大変そうですね。

id:suzufumi

ありがとうございます。

2010/10/11 10:55:44
id:Ktwo No.3

Ktwo回答回数21ベストアンサー獲得回数52010/10/11 05:03:14

ポイント24pt

(前提条件)

設問:A(1)列,F(6)列

チェック欄:B(2)~E(5)列,G(7)列~J(10)列

      (それぞれ3~10行目)

点数:0~3点

集計欄:H14

-----

得点計算もマクロに組み込みましたが、

Deleteボタンで○を消した場合には計算してませんので、

得点計算はSilvanusさんの回答の通り、数式(CountIf関数)が

よろしいかと思います。

尚、○を入力する欄は、セル結合するとNGです。

以下のソースを、Worksheetのコードとして保存して下さい。

(モジュールじゃないです)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next

Dim lRow, lColumn, lPoint  As Long

    '選択されたセル数
    If Target.Count <> 1 Then Exit Sub
    '列チェック
    If Target.Column < 2 Or _
       Target.Column = 6 Or _
       Target.Column > 10 Then Exit Sub
    '行チェック
    If Target.Row < 3 Or Target.Row > 10 Then Exit Sub

    '○編集
    Select Case Target.Column
        
        Case 2, 7
            Cells(Target.Row, Target.Column + 0) = "○"
            Cells(Target.Row, Target.Column + 1) = Empty
            Cells(Target.Row, Target.Column + 2) = Empty
            Cells(Target.Row, Target.Column + 3) = Empty
            
        Case 3, 8
            Cells(Target.Row, Target.Column - 1) = Empty
            Cells(Target.Row, Target.Column + 0) = "○"
            Cells(Target.Row, Target.Column + 1) = Empty
            Cells(Target.Row, Target.Column + 2) = Empty
            
        Case 4, 9
            Cells(Target.Row, Target.Column - 2) = Empty
            Cells(Target.Row, Target.Column - 1) = Empty
            Cells(Target.Row, Target.Column + 0) = "○"
            Cells(Target.Row, Target.Column + 1) = Empty
        
        Case 5, 10
            Cells(Target.Row, Target.Column - 3) = Empty
            Cells(Target.Row, Target.Column - 2) = Empty
            Cells(Target.Row, Target.Column - 1) = Empty
            Cells(Target.Row, Target.Column + 0) = "○"
        
    End Select

    '点数計算
    lPoint = 0
    For lRow = 3 To 10
        For lColumn = 2 To 10
            If Cells(lRow, lColumn) = "○" Then
                
                Select Case lColumn
                    
                    Case 3, 8
                        lPoint = lPoint + 1
                    
                    Case 4, 9
                        lPoint = lPoint + 2
                    
                    Case 5, 10
                        lPoint = lPoint + 3
                        
                End Select
            End If
        Next
    Next
    Cells(14, "H").Value = lPoint
    
End Sub
id:suzufumi

ありがとうございます。

2010/10/11 10:55:54
id:Silvanus No.4

Silvanus回答回数174ベストアンサー獲得回数672010/10/14 10:31:06ここでベストアンサー

ポイント24pt

プルダウン式はお気に召さなかったのでしょうか(汗)。

…あるいは、単にコメントに気付かれなかったのかも知れませんが。

ということで、こんな感じでいかがでしょうか。

http://rct3jp.info/hatena/BDTest.xls

もし、開いた後、スコアシートをクリックした際に「保護されていて変更できない…」と

叱られたら、一旦[校閲]-[シートの保護の解除]を行ない、その後に、

[開発]-[マクロ]から、マクロ"LockScoreSheet"を実行して下さい。

こうすると、患者さんがシートに対して行える操作はクリックのみとなり

シートの内容を勝手に変更できなくなります。

id:suzufumi

Silvanus 様、度々の回答及び作成、誠に有難うございます。

忙しくて、ここ数日はパソコンを開いてませんでした。

私の望んでいた通りの出来映えでした。有難うございます。

ここまで、作って頂いた上で恐縮ですが、作り方(マクロ?)を教えていただけないでしょうか?

似たようなチェックリストを今度は、自分で作ってみたいのです。

回答者制限を緩和しましたので、何卒、宜しくお願いします。

2010/10/16 21:08:20
  • id:Silvanus
    プルダウンメニューから回答を選択する方式ではダメですか?
    http://rct3jp.info/hatena/suzufumi_san_2.xls
  • id:Silvanus
    >suzufumiさん
    ご希望に適ったもので良かったです。そのワークブックの解説については
    暫くお待ち下さいますようお願い申し上げます。
  • id:Silvanus
    解説用に、シート保護の解除や、隠しておいた要素を表に出したバージョンを
    下記に保存しましたので、ダウンロードしてご覧になって下さい。
    不明な点がございましたら、遠慮無くお訊き下さい。
    http://rct3jp.info/hatena/BDTest_open.xls
    ---
    解説を始める前に是非ともご承知おきいただきたいのですが、私は
    Excelの達人でも何でもなく、私の方法が最善である訳がありません。
    飽くまで一つのやり方として、参考程度に止めおいて下さい。お願いします。
    今回は、VBAのマクロが可及的に簡単になる様に
    「セル/セル範囲に名前を付ける」ことをマメに行なっています。
    ---
    (1) 素材(ここではバーンズのテストシート)をみながらワークシートの設計を行ないます。
     各行や各列の高さ・幅は切りの良い数字に揃えておいた方が、見た目に綺麗です。
     また、今回は説明しませんが、マクロを使ってボタン等のコントロールを配置する時にも
     切りの良い数字にしておいた方が便利です。
    (2) セル、セル範囲に名前をつけます。
     現在、このワークブック内のセル/セル範囲につけられている名前の一覧表は
     メニュー[数式]→[定義された名前]→[名前の管理]でみることができます。
     どういう範囲にどういう名前を付けているのか、対応を確認してみて下さい。
     ※私はマクロを使って名前を定義しました。そのマクロは、また次のコメでお示しします。
    (3) 点数を算出するための数式を記入する。
     先程定義したセル範囲の名前を利用して、合計点数を算出するための数式を
     非表示に設定するO列に記述します。テストシートの右下に合計点を表示しますが
     ○をつけていない未回答の項目がある場合には警告を表示する様にIf()関数を用いています。
    (4) 透明のボタンとして用いるための「ラベル」コントロールを貼り込みます。
     メニュー[開発]→[コントロール]→[挿入]→[ラベル(フォームコントロール)]を選択し、
     先ずは1問目の0点の欄一杯の大きさにして貼り込みます。あとは15問×4レベル貼り込み等。
     最後に「全ての回答をクリアする」の文字の上に、貼り込みます。
     ※私はマクロを使ってコントロールを貼り込みました。そのマクロは、次のコメでお示しします。
    (5) マクロを作成します。
    ----------
    Option Explicit '宣言していない変数は使用できない(エラーが出る)
    'プログラミングの勉強中は必ずこれを書いておくようお奨めします。
    Sub RecalScore(intQNum As Integer, intSNum As Integer)
    ' メインルーチン
    ' 押されたラベルの問題番号と得点を引数として受け取る。
    Dim strQNum As String
    Dim strSNum As String
    strQNum = "Q" & Right("0" & Format(intQNum, "0"), 2)
    strSNum = "s" & Format(intSNum, "0")
    ' 問題番号と得点から、セルの参照範囲の定義された名前を表す文字列を得ます。
    Range(strQNum & "_" & "All").ClearContents
    ' 当該問題番号の記入欄(横4マス)の内容を一旦クリアする。
    Range(strQNum & "_" & strSNum).Value = "○"
    ' ラベルコントロールが押されたところに○を記入する。
    End Sub
    '
    Sub LockScoreSheet() ' マクロからのセルの内容の変更は許可するが
    'ユーザーによる変更は許可しない
    ActiveSheet.Protect UserInterfaceOnly:=True
    End Sub
    '
    Sub ClearScoreSheet() ' ○記入欄全体をクリアする
    Range("Q01_08_All").ClearContents '1問目から8問目の領域
    Range("Q09_15_All").ClearContents '9問目から15問目の領域
    End Sub
    '
    Sub Click_Label_Clear() ' ラベルコントロールをクリックすると呼び出されるマクロ
    ClearScoreSheet ' ○記入欄全体をクリアするルーチンを呼び出す。
    End Sub
    '
    Sub Click_Label_Q01_0() ' ラベルコントロールをクリックすると呼び出されるマクロ
    RecalScore 1, 0 ' メインルーチンを呼び出す。1番目の引数は押されたラベルの
    ' 問題番号、2番目の引数は押されたラベルの得点
    End Sub
    '
    <以下略>
    ----------
    (6) ワークシート上のラベルコントロールを右クリックし、マクロを割り当てていく。
     上記の"Click_Label_Qxx_x"、"Click_Label_Clear"を割り当てます。
    '
    こんな説明でショボイ説明でお解りいただけますでしょうか…。
    口で説明するのは簡単ですけど、文章に書いて説明するのはなかなか難しいです。
  • id:suzufumi
    丁寧な解説、本当に有難うございます<(_ _)>
    頑張ってみます。
  • id:Silvanus
    一応、BDTest.xlsに設定された全てのラベルと名前の定義を
    マクロで行なった場合は、この様な感じになります。ご参考までに。
    正直言いまして、この変態的なマクロが読めなくても(理解できなくても)全く問題ありません。
    -----
    Option Explicit
    '
    Sub SetControls() ' 今回、数式は数が少なかったので、マクロを使用せず手動で入力しました。
    '         数式はセル範囲の名前の定義が終わってから入力します。
    Const strPrfx As String = "='ScoreSheet'!"
    Dim intCount1 As Integer
    Dim intCount2 As Integer
    '
    ' Labels ※ラベルを貼る座標は、事前に[マクロ記録]下で手動でラベルを貼って調べておきます。
    '      行列の高さ・幅を切りの良い数字にしておくと楽です。
    '      当然のことですが、マクロを使用せず全部/一部を手動で貼っても全く問題ありません。
    With ActiveSheet.Labels
    For intCount1 = 0 To 7
    For intCount2 = 0 To 3
    .Add(285.75 + intCount2 * 30, 234.75 + intCount1 * 30, 28.5, 28.5).Characters.Text = ""
    Next
    Next
    For intCount1 = 0 To 6
    For intCount2 = 0 To 3
    .Add(675.75 + intCount2 * 30, 234.75 + intCount1 * 30 - ((intCount1 > 0) + (intCount1 > 2)) * 15, _
    28.5, 28.5 - (intCount1 = 0 Or intCount1 = 2) * 15).Characters.Text = ""
    Next
    Next
    .Add(486.75, 485.25, 128.25, 18.75).Characters.Text = ""
    End With
    '
    ' Definition of Name of Cell Range
    '
    With ActiveWorkbook.Names
    .Add Name:="NofMarks_All", RefersToR1C1:=strPrfx & "R8C15"
    .Add Name:="NofMarks_s0", RefersToR1C1:=strPrfx & "R9C15"
    .Add Name:="NofMarks_s1", RefersToR1C1:=strPrfx & "R10C15"
    .Add Name:="NofMarks_s2", RefersToR1C1:=strPrfx & "R11C15"
    .Add Name:="NofMarks_s3", RefersToR1C1:=strPrfx & "R12C15"
    .Add Name:="BDScore", RefersToR1C1:=strPrfx & "R13C15"
    .Add Name:="Q01_08_All", RefersToR1C1:=strPrfx & "R8C4:R23C7"
    .Add Name:="Q09_15_All", RefersToR1C1:=strPrfx & "R8C10:R23C13"
    ' 以上の名前の定義は手動でやる方が手間がかからない(繰り返しの要素が無い)。
    For intCount1 = 0 To 7
    .Add Name:="Q" & Right("0" & Format(intCount1 + 1, "0"), 2) & "_All", _
    RefersToR1C1:=strPrfx & AddrRC(8 + intCount1 * 2, 4, 9 + intCount1 * 2, 7)
    For intCount2 = 0 To 3
    .Add Name:="Q" & Right("0" & Format(intCount1 + 1, "0"), 2) & "_s" & Format(intCount2, "0"), _
    RefersToR1C1:=strPrfx & AddrRC(8 + intCount1 * 2, 4 + intCount2)
    Next
    Next
    For intCount1 = 0 To 6
    .Add Name:="Q" & Right("0" & Format(intCount1 + 9, "0"), 2) & "_All", _
    RefersToR1C1:=strPrfx & AddrRC(8 + intCount1 * 2 - ((intCount1 > 0) + (intCount1 > 2)), 10, _
    9 + intCount1 * 2 - ((intCount1 = 0) + (intCount1 > 0) + (intCount1 = 2) + (intCount1 > 2)), 13)
    For intCount2 = 0 To 3
    .Add Name:="Q" & Right("0" & Format(intCount1 + 9, "0"), 2) & "_s" & Format(intCount2, "0"), _
    RefersToR1C1:=strPrfx & AddrRC(8 + intCount1 * 2 - ((intCount1 > 0) + (intCount1 > 2)), 10)
    Next
    Next
    For intCount2 = 0 To 3
    .Add Name:="Q01_08_s" & Format(intCount2, "0"), _
    RefersToR1C1:=strPrfx & AddrRC(8, 4 + intCount2, 23, 4 + intCount2)
    .Add Name:="Q09_15_s" & Format(intCount2, "0"), _
    RefersToR1C1:=strPrfx & AddrRC(8, 10 + intCount2, 23, 10 + intCount2)
    Next
    End With
    '
    End Sub
    '
    Function AddrRC(ByVal lngR As Long, ByVal lngC As Long, Optional ByVal lngR2 As Long, Optional ByVal lngC2 As Long) As String
    AddrRC = "R" & Format(lngR, "0") & "C" & Format(lngC, "0")
    If lngR2 > 0 And lngC2 > 0 Then
    AddrRC = AddrRC & ":" & "R" & Format(lngR2, "0") & "C" & Format(lngC2, "0")
    End If
    End Function

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません