2013年4月5日金曜日

東京バリアフリー旅行記 1

ただし、中途半端。(途中から画像なしというイミで)

 仕事で利用者様に「車いすでも旅行できますよ。行ってみたらいいじゃないですか?」とのんきに言っていたのに、実は自分では体験していなかったのです。(旅行介護者の研修はしたことある)

 今回、実母の調子もよく、ヒコーキのタダ券もあるので、東京に行ってみました。
(ヒコーキのマイレージが 5万マイル越えてたのよ、一人ならヨーロッパ行けたけど、一人1万5千マイルで東京行き家族旅行にあてがったのよ。)

さて、3月下旬の土日に東京旅行に行ったのは、
ジジ : ウォーキングしてるので体力はある。
ババ : ペースメーカーが入っている。階段を数段上がれて、数歩なら歩ける。要支援1
ニャー : 上の娘。ジジとババが孫も連れてこいと言い、下の娘は用事があり、ニャーだけが来た。
そして私 の4人

小松空港

お留守番のだんなと下の子、タンポポ










春休みに入ってすぐで小松空港が超混んでいた。
羽田行きがANAとJALの2便が時間差ない上に、成田行きの国際線乗り継ぎのチェックインまでANAカウンターでしているので時間がかかる。

隣に並んだ人がビックリだった。成田行きのチケットを今買ってアメリカに行くそうな。
え?成田行きを正規料金で買ったの?何万するんやろ?

チェックインはババが車いす(自家用は荷物預け、空港内はANAのを借りれる)なのでいくつか質問を受けた。
「飛行機までは車いすを利用できますが、機内は歩けますか?」
「飛行機を降りるときは最終になりますがいいですか?」
「飛行機を降りて羽田空港内保安エリアは同行者が車いすを押せますか?」

ジジとババは小松空港で朝食をとるつもりで、先に2階の喫茶店に入ったのだが、そこも混んでて遅くて、パンを受け取ったら持って出てきたそうな。

ババが車いすなので優先搭乗できるのだけど、保安検査を抜けるのに時間がかかってほぼ最終搭乗。

4人並びの席を早々に予約してあったのと、地上係員とCAの連携がうまく行っていてスムーズに搭乗できた。

久しぶりのヒコーキ。うれしい。

ババがさっそくやってくれた。
ヒコーキが降下し始めるので席に着くように案内があった直後に「トイレに行っとくわ」
わー、今からかい!
CAにギャレーの中を通らせてもらい、なんとかセーフ。

着地は私の中のベスト3に入るくらい、上手だった。

羽田に到着すると、結構待ってから座席からすぐの出口に車いすを用意してくれていた。

ここで、わかったこと
ヒコーキ近くまでANAの車いすを持ってきてくれる。



2階到着階から1階のターンテーブルに向かう。




















羽田のエレベーターは広い。













荷物を受け取り、自家用車いすに乗り換え、ババはまた身障者用トイレでゆっくり。

まず、羽田からモノレールで浜松町へ向かう。

当日から全国の交通カードが相互に使えるようになった。
すでに持っているsuica1枚とPASMO2枚の他に関西のPiTaPa1枚が使えるようになって、全員交通関係はスルーになった。
(身障手帳を持っていると電車等も割引になるけど、1回1回面倒なのでカードでピ!にした。)

モノレールに乗ろうとすると、改札口から係員が付き添ってくれた。
「電車への出入りは歩けますので大丈夫です。」と言うと、
「では、出入り用の板(段差解消)の用意と、到着駅への連絡はいりませんね。」と言われた。
そんなこともしてくれるのね。

ここで、わかったこと
モノレールは電車への出入り用の板でラクに乗れて、到着駅へ連絡して降りも同様にしてくれる。


私は軽くソラ。

ヒコーキより空港が好きかも。












モノレールの乗り降りは、片手に杖、片手引きで可能。

車内は出入り口すぐのところへ座る。うまいこと快速に乗れて特に問題なし。

浜松町に着き、モノレールの改札を出る。

次はタクシーに乗るので1階へ。
エレベーターで移動。
問題なし。









































タクシー乗り場(緑色)へ向かう途中、またもやババが「トイレ行っとくわ」と言いだす。
ここでかよ!

この近辺で身障者用トイレは探してなかった。

とりあえず、モノレール駅構内はパス。(人が多くて待ちそうだし)

隣の世界貿易センターに入る。
(駅より清潔そうじゃないですか?)




















が、しかし分かりやすいところのトイレはなんと5段も下にあった!

ババは「このくらいなら行ける」というので、がんばらせる。
(スパルタですか?いや自立支援です!)

あとで調べたら別館に身障者用トイレがあった。
















中型タクシーの運転手さんに
「車いすですが、いいですか?」(以降タクシーに乗るときはずっと)と聞いて、トランクに車いすを入れてもらう。

行き先は、
荷物を預けるために三田のホテルに寄ってもらい、
広尾(恵比寿駅近く)の美術館。

途中、芝を通り
きゃりーぱみゅぱみゅがKDDIのCMしていた増上寺を見る。

画像はCMより








増上寺って、有名人の葬式はするし、キャパ広い。

そして麻布界隈を通る。
「あー、ここ歩いた。」なところがあり、点と点がつながるのがうれしい。
歩いたのは東京に住んでいたころではなく、その後、研修とかで東京に来たとき。

中国大使館も近くにあり、厳重な警備をしていた。
サン・マリノ共和国(バチカンしかないところ)の大使館を見つけたニャーが喜んでいた。

そして、広尾に到着

山種美術館

山種証券(現・SMBCフレンド証券)およびヤマタネの創業者・故山崎種二が長年にわたって蒐集した美術品の寄附により1966年に開館した東京都渋谷区、日本画の専門美術館「山種美術館」

日本画の専門美術館というだけあって、近代のおもだった画家の作品が多いです。












例えば
横山大観(よこやま・たいかん)

 奥村土牛(おくむら・とぎゅう)
上村松園(うえむら・しょうえん)


 






など。当然作品は撮影禁止。

エレベーターの中

ボタンもスタイリッシュ
入口正面の蒔絵

この下の階が展示フロア


















大人 1000円
大学・高校生 800円

「障害者手帳、被爆者手帳ご提示の方および その介助者(1名)は無料」と太っ腹で、結局私とニャーの分しか払わなくてよかった。

ツウな美術館なので、入館者も落ち着いた層だった。

これだけ日本画ばかり見るのは久しぶり。

ダンナは「別の用事がなく、絵を見るために東京へ行くのか?」と不思議がっていたが、私の実家はそういうウチだ。
だから、ルーヴル美術館へ行ったのさ!


カフェを併設しており、ゆっくりと休める。














トイレも身障者用完備!

ここで、わかったこと
ゆったりとした山種美術館は障害者に優しい

2013年3月16日土曜日

バランスWiiボードとPCで重心動揺計を作る 6


Excelでグラフにする 4

前回の続きです。


'グラフ作成
    Range("B4:C20").Select                                     'B4からC20の範囲を選択
    Charts.Add                                                 'グラフを挿入する
    ActiveChart.ChartType = xlXYScatterSmooth                   'グラフタイプは平滑線付き散布図・・・①
    ActiveChart.SetSourceData Source:=Sheets("作業用").Range("D2:E7000"), PlotBy:= _
        xlColumns                                                                     'データは作業用シートのD2からE7000
    ActiveChart.Location Where:=xlLocationAsObject, Name:="作業用"
    ActiveChart.SeriesCollection(1).Name = "重心軌跡"
     With ActiveSheet.ChartObjects("グラフ 1")                          '現在のシートの「グラフ1」は
        .Top = Range("G18").Top                                         '上端をG18セルに配置
        .Left = Range("G18").Left                                       '左端をG18セルに配置
                                             
    End With
-----------------------------
1段目の
Range("B4:C20").Select                                     'B4からC20の範囲を選択
はこの辺をグラフにするよ、ということ。

は平滑線なので各点を直線で結びたいときは「xlXYScatterSmooth」を「xlXYScatterLines」に変更します。
-----------------------------
    ActiveChart.Axes(xlValue).Select                            'アクティブグラフを選択
    With ActiveChart.Axes(xlValue)                              'グラフX軸について
        .MinimumScale = -20                                     '最少値を-20Cm・・・②
        .MaximumScale = 20                                      '最大値を20Cm・・・②
        .MinorUnitIsAuto = True                                 '最少目盛は自動
        .MajorUnit = 5                                          '最大目盛を5Cm
        .Crosses = xlAutomatic                                  '交点は自動
        .ReversePlotOrder = False
        .ScaleType = xlLinear
        .DisplayUnit = xlNone
    End With
    
    With ActiveChart.Axes(xlCategory)                           'グラフY軸について
        .MinimumScale = -20                                     '最少値を-20Cm・・・③
        .MaximumScale = 20                                      '最大値を20Cm・・・③
        .MinorUnitIsAuto = True                                 '最少目盛は自動
        .MajorUnit = 5                                          '最大目盛を5Cm
    End With
---------------------------------
はX軸の最小大値設定で、あまり動揺のない人が対象なら、20cmから減らします。
逆に動作時の動揺を図るためならもっと大きくすることもできます。もちろんWiiボードのサイズ以下ですよ。
はY軸で同様です。

---------------------------------
    '矩形グラフ
    ActiveChart.SeriesCollection.NewSeries.MarkerStyle = xlMarkerStyleNone     'アクティブグラフに新規グラフを追加
    ActiveChart.SeriesCollection(2).XValues = "='作業用'!$K$12:$K16"            'X値は作業用シートK12からK16
    ActiveChart.SeriesCollection(2).Values = "='作業用'!$L$12:$L$16"            'Y値は作業用シートL12からL16
    ActiveChart.SeriesCollection(2).Points(2).Select                           '新規グラフを選択
    ActiveChart.SeriesCollection(2).ChartType = xlXYScatterLinesNoMarkers      '折れ線グラフでマーカーなし
    ActiveChart.SeriesCollection(2).Name = "矩形"                              '系列名を「矩形」
   ---------------------------------
矩形グラフの様式です。
線の色の変更の仕方をどうすればいいかわかりません。
誰か教えてください。
--------------------------------- 
    '中心点ドット
    ActiveChart.SeriesCollection.NewSeries.MarkerStyle = xlMarkerStyleDot     'アクティブグラフに新規グラフを追加
    ActiveChart.SeriesCollection(3).XValues = "='作業用'!$H$12"                'X値は作業用シートH12
    ActiveChart.SeriesCollection(3).Values = "='作業用'!$I$12"                 'Y値は作業用シートI12
    ActiveChart.SeriesCollection(3).Name = "中心点"                           '系列名を「中心点」
    
    With Range("G13:O30")
        ActiveSheet.ChartObjects("グラフ 1").Width = .Width
        ActiveSheet.ChartObjects("グラフ 1").Height = .Height
    End With
    
--------------------------
中心点のグラフ表示です。
同じくマーカーの色の変え方もわかりません。
--------------------------  
    ActiveChart.HasTitle = True                                 'アクティブグラフのタイトル
    ActiveChart.ChartTitle.Text = "重心動揺計測 単位(cm)"    '「重心動揺計測 単位(cm)」を入力
    ActiveChart.ChartTitle.Font.Size = 16                       'フォントを16ポイント
------------------------
グラフのタイトルです。
" "の間の字を変更できます。
------------------------  
    'プレビューボタンを作る
    ActiveSheet.Buttons.Add(536.25, 6, 42.75, 14.25).Select
    Selection.OnAction = "プレビュー"
    ActiveSheet.Shapes("Button 1").Select
    Selection.Characters.Text = "プレビュー"
    With Selection.Characters(Start:=1, Length:=5).Font
        .Name = "MS Pゴシック"
        .FontStyle = "標準"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone

    End With
    Selection.ShapeRange.ScaleWidth 1.86, msoFalse, msoScaleFromTopLeft
------------------------------
プレビューボタンを貼り付けました。
印刷では非表示になります。
------------------------------
      
    'シート名変更
        Worksheets("作業用").Name = "重心動揺" & Format(Time, "hhnn")
    
        MsgBox "処理が完了しました。", vbOKOnly, "完了"
        Worksheets(1).Select
End Sub

-----------------------------
一旦「作業用」というシートを作りましたが、次に同じ「作業用」という名前のシートが作れないのと、数件あるとどれが誰だかわからなくなるので、時間をつけました。
時間は処理した時間○時○分です。
処理が終わるとメッセージが出ます。
-----------------------------

Sub プレビュー()
    ActiveSheet.PageSetup.RightFooter = "Powerd by KITA Ver1.00"
    Range("G1:O36").PrintPreview                                'G1からO40セルの範囲をプレビュー表示

End Sub
-----------------------------
プレビューボタンを押したときに実行するマクロです。
Excelってページが縦に進んでいくので、7000ケタもあると範囲を出すのがとんでもなく大変なので。
-----------------------------

と、これでコードの解説は終わりました。
うーん、ずいぶん長い時間(3ヶ月)かかって(とりあえず)できた、と達成感。

最後に
評価ツールはツールであって、そこから得られたデータを分析して、治療に結び付けてナンボだと思います。データを取ることが目標にならないようにしてくださいね。

私はPT歴20年超ですが、臨床実習指導もしたことないし、そもそもなりたくてなった職業ではないので仕事に対する温度は低いです。(仕事はまじめにやってますよ!)
でも、このマクロがPTだけでなく他の方のお役に立てば、私の役目は果たしたかなと思います。

それでは、これで「バランスWiiボードとPCで重心動揺計を作る」シリーズは終了します。

2013年3月15日金曜日

バランスWiiボードとPCで重心動揺計を作る 5


Excelでグラフにする

今回すること

3 マクロを実行してデータ操作ができるようにする。

やる気マンマンの方はもう試したかもしれませんが、今回はデータを操作できるようにします。
-----に囲まれたところで解説します。
赤字は解説ポイントです。実際のコードにはありませんし、この部分のコードをコピペすると動かないかも。
前回の 「バランスWiiボードとPCで重心動揺計を作る 4」 をコピペしてください。
コード後方の緑字はそのコードのイミです。

Sub 空白セル()
    Worksheets("sheet0").Select
    Range("H1").Formula = "=countIf((A1:B7000),""*"")"
    If Range("H1") > 0 Then MsgBox "文字型セルがありました。" & vbCrLf & "処理を中止します。", vbOKOnly, "文字型セル"
    
    Worksheets("sheet0").Range("A1:B7000").Select
    Dim Rng As Range
    Set Rng = Selection
    On Error GoTo errhandler
    Selection.SpecialCells(xlCellTypeBlanks).Select
    MsgBox "空白セルがありました。" & vbCrLf & "処理を中止します。", vbOKOnly, "空白セル"
    Set Rng = Nothing
    Exit Sub
errhandler:
    MsgBox "文字型セル、空白セルはありませんでした。処理を続けます。", vbOKOnly, "セル内容"
    If vbOK Then Call 作業シート
End Sub

------------------------------
Sub空白セル()について(ココはコメントなし)
sheet0のA1からB7000の範囲に文字、空白があればグラフ化できないので、
調べて大丈夫なら次のマクロを続行します。
sheet0のH1セルに計算結果を出力しますので、そのセルに入力してあったものは置換されます。
------------------------------

Sub 作業シート()
    
    '作業用というシートを作る
    ActiveWorkbook.Sheets.Add.Name = "作業用"
   
    Range("g1").Value = "重心動揺計測"        'G1セルにタイトルを入力
    With Range("G1").Font                     'G1セルのフォントについて
        .Name = "MS明朝"                      'MS明朝体
        .Bold = True                          '太字
        .Color = vbBlue                       '青字
        .FontStyle = "斜体"                   '斜体
        .OutlineFont = True                   'アウトラインフォント
        .Size = 22                            '22ポイント
    End With
------------------------------
Sub作業シート()について
新しいワークシート「作業シート」を追加してタイトルをつけます。
「重心動揺計測」というタイトルを変更するなら、黒字のコードの
"重心動揺計測"を"変更したもの" に変えればいいです。「"」で挟むのを忘れずに。
同じようにサイズを変えたければ、黒字の「22」を変更します。(ココは「"」はなし)
------------------------------
    Range("A1").Value = "No"                  'A1セルに「No」を入力
    Range("B1").Value = "X値"                 'B1セルに「X値」を入力
    Range("C1").Value = "Y値"                 'C1セルに「Y値」を入力
    Range("D1").Value = "X座標"               'D1セルに「X座標」を入力
    Range("E1").Value = "Y座標"               'E1セルに「Y座標」を入力
       
    Columns("G").ColumnWidth = 16                 'Gのセルの幅を16
    Range("G3:G8").HorizontalAlignment = xlCenter 'G3からG8範囲を中心揃え
    Range("G3:P38").RowHeight = 22                'G3からP38範囲の行の高さを22
    Range("H:N").ColumnWidth = 8                  'HからN範囲の幅を8
    Range("G3:G8").Interior.ColorIndex = 34       'G3からG8範囲のセル内を34番の色
    Range("I3").Interior.ColorIndex = 34          'I3のセル内を34番の色
    Range("K3").Interior.ColorIndex = 34          'K3のセル内を34番の色
    Range("M3").Interior.ColorIndex = 34          'M3のセル内を34番の色
    Range("K4").Interior.ColorIndex = 34          'K4のセル内を34番の色
    
    Range("H4:J4").Merge                          'H5からN5セルを結合
    Range("L4:N4").Merge                          'H5からN5セルを結合
    Range("H5:N5").Merge                          'H5からN5セルを結合
    Range("H6:N6").Merge                          'H6からN6セルを結合
    Range("H7:N7").Merge                          'H7からN7セルを結合
    Range("H8:N8").Merge                          'H8からN8セルを結合

    Range("G3").Value = "No"                      'G3セルに「No」を入力

    Range("I3").Value = "年齢"                    'I3セルに「年齢」を入力
    Range("K3").Value = "性別"                    'K3セルに「性別」を入力
    Range("M3").Value = "転倒回数"                'M3セルに「転倒回数」を入力
    Range("G4").Value = "視覚情報の有無"          'G4セルに「視覚情報の有無」を入力
    Range("K4").Value = "計測日"                  'K4セルに「計測日」を入力
    Range("L4").Value = Format(Date)             'L4セルに今日の日付を入力・・・①
    Range("G5").Value = "疾患"                    'G5セルに「疾患」を入力
    Range("G6").Value = "障害"                    'G6セルに「障害」を入力
    Range("G7").Value = "肢位"                    'G7セルに「肢位」を入力
    Range("G8").Value = "備考"                    'G8セルに「備考」を入力

----------------------------------
個人情報を入力する欄の書式です。入力した文字や色を変えるには黒字の部分を変更します。

下から5行目のRange("L4").Value = Format(Date) はデータ処理の日付を自動入力しています。計測日が処理日でないなら、この1行を消去します。(保存したら以降の処理はすべて日付なしになります。)

----------------------------------
  
    'データを作業用シートにコピーする
    Worksheets("Sheet0").Select                             'sheet0を選択・・・②
    Range("A1:B" & Range("B1").End(xlDown).Row).Copy _
    Destination:=Worksheets("作業用").Range("B2")        'A1からB列最終行までコピーし作業用シートのB2に貼り付け
----------------------------------
sheet0のデータを壊さない、消去しないように、作業用シートに貼り付けます。
ですから、sheet1にデータがあるからそのまま処理したいという場合には"sheet0"をそのシート名にします。その時は他のsheet0が出てくるところも変更してください。「検索」でsheet0調べてね。
----------------------------------

    '座標を求める

    Worksheets("作業用").Select                             '作業用シートを選択
    Range("D2").Formula = "=B2/40*43"                       'D2にB2÷40×43を入力  (※1)
    Range("D3").Formula = "=B3/40*43"                       'D3にB3÷40×43を入力
    Range("D2:D3").AutoFill Destination:=Range("D2:D7000")   'D2、D3のようにD7000まで入力
    
    Range("E2").Formula = "=C2/24*23.2"                     'E2にC2÷24×23.2を入力
    Range("E3").Formula = "=C3/24*23.2"                     'E3にC3÷24×23.2を入力
    Range("E2:E3").AutoFill Destination:=Range("E2:E7000")   'E2、E3のようにE7000まで入力

----------------------------------
データはWiiボードの計測値なのでcm単位に直します。
リハビリテーションツール研究所の掲示板の吉村さんコメントから
出力された数値はセンサから得られた値そのままです。
X軸は-20~+20、Y軸は-12~+12の範囲です。
一方、実際のバランスWiiボードのセンサーは横43㎝、縦23.2㎝の間隔で設置されています。
したがって、出力されたX座標を40で割って43をかける、Y座標を24で割って23.2をかけると㎝に変換できます。
とあるので計算式を入れました。

----------------------------------
    '平均、標準偏差を求める
    Range("G12:G16").HorizontalAlignment = xlCenter          'G12からG16範囲を中心揃え
    Range("H11").Value = "X(cm)"                          'H11セルに「X(cm)」を入力
    Range("I11").Value = "Y(cm)"                          'I11セルに「Y(cm)」を入力
    Range("G12").Value = "平均"                             'G12セルに「平均」を入力
    Range("H12").Formula = "=AVERAGE(D2:D7000)"              'H12セルにD2からD7000の平均を入力
    Range("I12").Formula = "=AVERAGE(E2:E7000)"              'I12セルにE2からE7000の平均を入力
    
    Range("G13").Value = "標準偏差"                          'G13セルに「標準偏差」を入力
    Range("H13").Formula = "=STDEVP(D2:D7000)"                'H13セルにD2からD7000の標準偏差を入力
    Range("I13").Formula = "=STDEVP(E2:E7000)"                'I13セルにE2からE7000の標準偏差を入力
    
    '最大値、最小値を求める
    Range("G14").Value = "最大値"                            'G14セルに「最大値」を入力
    Range("H14").Formula = "=max(D2:D7000)"                   'H14セルにD2からD7000の最大値を入力
    Range("I14").Formula = "=max(E2:E7000)"                   'I14セルにE2からE7000の最大値を入力
    Range("G15").Value = "最小値"                            'G15セルに「最小値」を入力
    Range("H15").Formula = "=min(D2:D7000)"                   'H15セルにD2からD7000の最小値を入力
    Range("I15").Formula = "=min(E2:E7000)"                   'I15セルにE2からE7000の最小値を入力
--------------------------------
平均は中心、最大値・最小値は矩形の辺になります。
標準偏差はとりあえず作ってみました。(標準偏差が何かをよくわかっていない)
--------------------------------     
'矩形面積を求める
    Range("G16").Value = "矩形面積(cm2)"                   'G16セルに「矩形面積(cm2)」を入力
    Range("H16:I16").Merge across:=True                      'H16とI16セルを結合
    Range("H16").Formula = "=(H14-H15)*(I14-I15)"            '矩形の面積をH16セルに入力
   
   '矩形座標
    Range("K10").Value = "矩形"                              'K10セルに「矩形」を入力
    Range("K11").Value = "X(cm)"                           'K11セルに「X(cm)」を入力
    Range("L11").Value = "Y(cm)"                           'L11セルに「Y(cm)」を入力
    Range("K12").Value = "=(H14)"                            'K12セルにXの最大値を入力
    Range("L12").Value = "=(I15)"                            'L12セルにYの最小値を入力
    Range("K13").Value = "=(H15)"                            'K13セルにXの最小値を入力
    Range("L13").Value = "=(I15)"                            'L13セルにYの最小値を入力
    Range("K14").Value = "=(H15)"                            'K14セルにXの最小値を入力
    Range("L14").Value = "=(I14)"                            'L14セルにYの最大値を入力
    Range("K15").Value = "=(H14)"                            'K15セルにXの最大値を入力
    Range("L15").Value = "=(I14)"                            'L15セルにYの最大値を入力
    Range("K16").Value = "=(H14)"                            'K16セルにXの最大値を入力
    Range("L16").Value = "=(I15)"                            'L16セルにYの最小値を入力
    Range("M12").Value = "右下"                              'M12セルに「右下」を入力
    Range("M13").Value = "左下"                              'M13セルに「左下」を入力
    Range("M14").Value = "左上"                              'M14セルに「左上」を入力
    Range("M15").Value = "右上"                              'M15セルに「右上」を入力
    Range("M16").Value = "右下"                              'M16セルに「右下」を入力
 --------------------------------
矩形の座標を求めました。
右下-左下-左上-右下と単純に入力するだけ作業なのに疲れました。
--------------------------------
    '罫線をひく
    Range("G3:N8").Borders.LineStyle = xlContinuous                'G3からN8の範囲に細実線をひく
    Range("G3:N8").Borders.ColorIndex = 33                         'G3からN8の線の色を33番(青)色にする
    
    Range("G11:I16").Borders.LineStyle = xlContinuous               'G11からI16の範囲に細実線をひく
    Range("G11:I16").Borders.ColorIndex = 33                        'G11からI16の線の色を33番(青)色にする
    Range("G11:I11").Borders(xlEdgeBottom).LineStyle = xlDouble     'G11からI11の下端の横線を二重線にする

    Range("K11:L16").Borders.LineStyle = xlContinuous              'K11からL16の範囲に細実線をひく

    Range("K11:L16").Borders.ColorIndex = 33                       'K11からL16の線の色を33番(青)色にする
    Range("K11:L11").Borders(xlEdgeBottom).LineStyle = xlDouble    'K11からL11の下端の横線を二重線にする

----------------------------------
情報入力の表のところの罫線です。
色とか変えたかったら、黒字のコードを変更してください。
----------------------------------

うー、いっぱいになったから、あとは次回に


2013年3月13日水曜日

バランスWiiボードとPCで重心動揺計を作る 4

Excelでグラフにする 2

今回すること
2 このブログからマクロをコピーしてExcelに貼り付ける。


前回までで標準モジュールは挿入できていますね。

今回はマクロ(コード)を設定します。

先に言っとく。VBA初級者の無理やりなチカラ技です。コードも美しくありません。
できたものは中央揃いになってないところとかバラバラです。
VBAができる方はこのコードをタタキ台にして効率よく、美しく書き直して使ってください。(←ぶっ放し)

まず、生データのシートの名前を「sheet0」に直しておく。おそらくデータはsheet1から順に入っていると思うので、シートを間違わないようにしました。そしてデータはA1:B1セルを先頭にすること。

計測値はプロトコルに従えば60秒=6000ケタですが、前後余裕を見て7000ケタ計算します。このへんはご自分で変更できるように解説をつけてあります。(後日くわしくお伝えします。)
追記:変更すると計算できなくなるので変更しないでください。

厳密に6000ケタもなくても、連続したデータがあれば大丈夫です。

Module1をダブルクリックすると右側が新しく開きます。













 そこへ下の赤線と赤線の間のコードを貼り付けます。
「空白セル」「作業シート」「プレビュー」大きく3つのコードでできていますが、ひとつずつ貼り付けではなく、赤線から赤線までひとかたまりでコピペ。

下部のコードはこのブログ上で変な位置で改行されていても絶対に段をイジらないこと!
貼り付けてうまくいくと行の後方の「‘」から後ろが緑字になるはず。(コメント欄なのだ)
保存をお忘れなく。

-------------------------

Sub 空白セル()
    Worksheets("sheet0").Select
    Range("H1").Formula = "=countIf((A1:B7000),""*"")"
    If Range("H1") > 0 Then MsgBox "文字型セルがありました。" & vbCrLf & "処理を中止します。", vbOKOnly, "文字型セル"
    
    Worksheets("sheet0").Range("A1:B7000").Select
    Dim Rng As Range
    Set Rng = Selection
    On Error GoTo errhandler
    Selection.SpecialCells(xlCellTypeBlanks).Select
    MsgBox "空白セルがありました。" & vbCrLf & "処理を中止します。", vbOKOnly, "空白セル"
    Set Rng = Nothing
    Exit Sub
errhandler:
    MsgBox "文字型セル、空白セルはありませんでした。処理を続けます。", vbOKOnly, "セル内容"
    If vbOK Then Call 作業シート
End Sub

Sub 作業シート()
    
    '作業用というシートを作る
    ActiveWorkbook.Sheets.Add.Name = "作業用"
   
    Range("g1").Value = "重心動揺計測"        'G1セルにタイトルを入力
    With Range("G1").Font                     'G1セルのフォントについて
        .Name = "MS明朝"                      'MS明朝体
        .Bold = True                          '太字
        .Color = vbBlue                       '青字
        .FontStyle = "斜体"                   '斜体
        .OutlineFont = True                   'アウトラインフォント
        .Size = 22                            '22ポイント
    End With

    Range("A1").Value = "No"                  'A1セルに「No」を入力
    Range("B1").Value = "X値"                 'B1セルに「X値」を入力
    Range("C1").Value = "Y値"                 'C1セルに「Y値」を入力
    Range("D1").Value = "X座標"               'D1セルに「X座標」を入力
    Range("E1").Value = "Y座標"               'E1セルに「Y座標」を入力
       
    Columns("G").ColumnWidth = 16                 'Gのセルの幅を16
    Range("G3:G8").HorizontalAlignment = xlCenter 'G3からG8範囲を中心揃え
    Range("G3:P38").RowHeight = 22                'G3からP38範囲の行の高さを22
    Range("H:N").ColumnWidth = 8                  'HからN範囲の幅を8
    Range("G3:G8").Interior.ColorIndex = 34       'G3からG8範囲のセル内を34番の色
    Range("I3").Interior.ColorIndex = 34          'I3のセル内を34番の色
    Range("K3").Interior.ColorIndex = 34          'K3のセル内を34番の色
    Range("M3").Interior.ColorIndex = 34          'M3のセル内を34番の色
    Range("K4").Interior.ColorIndex = 34          'K4のセル内を34番の色
    
    Range("H4:J4").Merge                          'H5からN5セルを結合
    Range("L4:N4").Merge                          'H5からN5セルを結合
    Range("H5:N5").Merge                          'H5からN5セルを結合
    Range("H6:N6").Merge                          'H6からN6セルを結合
    Range("H7:N7").Merge                          'H7からN7セルを結合
    Range("H8:N8").Merge                          'H8からN8セルを結合

    Range("G3").Value = "No"                      'G3セルに「No」を入力
    Range("I3").Value = "年齢"                    'I3セルに「年齢」を入力
    Range("K3").Value = "性別"                    'K3セルに「性別」を入力
    Range("M3").Value = "転倒回数"                'M3セルに「転倒回数」を入力
    Range("G4").Value = "視覚情報の有無"          'G4セルに「視覚情報の有無」を入力
    Range("K4").Value = "計測日"                  'K4セルに「計測日」を入力
    Range("L4").Value = Format(Date)             'L4セルに今日の日付を入力
    Range("G5").Value = "疾患"                    'G5セルに「疾患」を入力
    Range("G6").Value = "障害"                    'G6セルに「障害」を入力
    Range("G7").Value = "肢位"                    'G7セルに「肢位」を入力
    Range("G8").Value = "備考"                    'G8セルに「備考」を入力
    
    'データを作業用シートにコピーする
    Worksheets("Sheet0").Select                             'sheet0を選択
    Range("A1:B" & Range("B1").End(xlDown).Row).Copy _
    Destination:=Worksheets("作業用").Range("B2")           'A1からB列最終行までコピーし作業用シートのB2に貼り付け

    '座標を求める
    Worksheets("作業用").Select                             '作業用シートを選択
    Range("D2").Formula = "=B2/40*43"                       'D2にB2÷40×43を入力  (※1)
    Range("D3").Formula = "=B3/40*43"                       'D3にB3÷40×43を入力
    Range("D2:D3").AutoFill Destination:=Range("D2:D7000")   'D2、D3のようにD7000まで入力
    
    Range("E2").Formula = "=C2/24*23.2"                     'E2にC2÷24×23.2を入力
    Range("E3").Formula = "=C3/24*23.2"                     'E3にC3÷24×23.2を入力
    Range("E2:E3").AutoFill Destination:=Range("E2:E7000")   'E2、E3のようにE7000まで入力
        
    '平均、標準偏差を求める
    Range("G12:G16").HorizontalAlignment = xlCenter          'G12からG16範囲を中心揃え
    Range("H11").Value = "X(cm)"                          'H11セルに「X(cm)」を入力
    Range("I11").Value = "Y(cm)"                          'I11セルに「Y(cm)」を入力
    Range("G12").Value = "平均"                             'G12セルに「平均」を入力
    Range("H12").Formula = "=AVERAGE(D2:D7000)"              'H12セルにD2からD7000の平均を入力
    Range("I12").Formula = "=AVERAGE(E2:E7000)"              'I12セルにE2からE7000の平均を入力
    
    Range("G13").Value = "標準偏差"                          'G13セルに「標準偏差」を入力
    Range("H13").Formula = "=STDEVP(D2:D7000)"                'H13セルにD2からD7000の標準偏差を入力
    Range("I13").Formula = "=STDEVP(E2:E7000)"                'I13セルにE2からE7000の標準偏差を入力
    
    '最大値、最小値を求める
    Range("G14").Value = "最大値"                            'G14セルに「最大値」を入力
    Range("H14").Formula = "=max(D2:D7000)"                   'H14セルにD2からD7000の最大値を入力
    Range("I14").Formula = "=max(E2:E7000)"                   'I14セルにE2からE7000の最大値を入力
    Range("G15").Value = "最小値"                            'G15セルに「最小値」を入力
    Range("H15").Formula = "=min(D2:D7000)"                   'H15セルにD2からD7000の最小値を入力
    Range("I15").Formula = "=min(E2:E7000)"                   'I15セルにE2からE7000の最小値を入力
    
    '矩形面積を求める
    Range("G16").Value = "矩形面積(cm2)"                   'G16セルに「矩形面積(cm2)」を入力
    Range("H16:I16").Merge across:=True                      'H16とI16セルを結合
    Range("H16").Formula = "=(H14-H15)*(I14-I15)"            '矩形の面積をH16セルに入力
   
   '矩形座標
    Range("K10").Value = "矩形"                              'K10セルに「矩形」を入力
    Range("K11").Value = "X(cm)"                           'K11セルに「X(cm)」を入力
    Range("L11").Value = "Y(cm)"                           'L11セルに「Y(cm)」を入力
    Range("K12").Value = "=(H14)"                            'K12セルにXの最大値を入力
    Range("L12").Value = "=(I15)"                            'L12セルにYの最小値を入力
    Range("K13").Value = "=(H15)"                            'K13セルにXの最小値を入力
    Range("L13").Value = "=(I15)"                            'L13セルにYの最小値を入力
    Range("K14").Value = "=(H15)"                            'K14セルにXの最小値を入力
    Range("L14").Value = "=(I14)"                            'L14セルにYの最大値を入力
    Range("K15").Value = "=(H14)"                            'K15セルにXの最大値を入力
    Range("L15").Value = "=(I14)"                            'L15セルにYの最大値を入力
    Range("K16").Value = "=(H14)"                            'K16セルにXの最大値を入力
    Range("L16").Value = "=(I15)"                            'L16セルにYの最小値を入力
    Range("M12").Value = "右下"                              'M12セルに「右下」を入力
    Range("M13").Value = "左下"                              'M13セルに「左下」を入力
    Range("M14").Value = "左上"                              'M14セルに「左上」を入力
    Range("M15").Value = "右上"                              'M15セルに「右上」を入力
    Range("M16").Value = "右下"                              'M16セルに「右下」を入力
    
    '罫線をひく
    Range("G3:N8").Borders.LineStyle = xlContinuous                'G3からN8の範囲に細実線をひく
    Range("G3:N8").Borders.ColorIndex = 33                         'G3からN8の線の色を33番(青)色にする
    
    Range("G11:I16").Borders.LineStyle = xlContinuous               'G11からI16の範囲に細実線をひく
    Range("G11:I16").Borders.ColorIndex = 33                        'G11からI16の線の色を33番(青)色にする
    Range("G11:I11").Borders(xlEdgeBottom).LineStyle = xlDouble     'G11からI11の下端の横線を二重線にする

    Range("K11:L16").Borders.LineStyle = xlContinuous              'K11からL16の範囲に細実線をひく
    Range("K11:L16").Borders.ColorIndex = 33                       'K11からL16の線の色を33番(青)色にする
    Range("K11:L11").Borders(xlEdgeBottom).LineStyle = xlDouble    'K11からL11の下端の横線を二重線にする


    'グラフ作成
    Range("B4:C20").Select                                     'B4からC20の範囲を選択
    Charts.Add                                                 'グラフを挿入する
    ActiveChart.ChartType = xlXYScatterSmooth                   'グラフタイプは平滑線付き散布図
    ActiveChart.SetSourceData Source:=Sheets("作業用").Range("D2:E7000"), PlotBy:= _
        xlColumns                                                                     'データは作業用シートのD2からE7000
    ActiveChart.Location Where:=xlLocationAsObject, Name:="作業用"
    ActiveChart.SeriesCollection(1).Name = "重心軌跡"
     With ActiveSheet.ChartObjects("グラフ 1")                          '現在のシートの「グラフ1」は
        .Top = Range("G18").Top                                         '上端をG18セルに配置
        .Left = Range("G18").Left                                       '左端をG18セルに配置
                                             
    End With

    ActiveChart.Axes(xlValue).Select                            'アクティブグラフを選択
    With ActiveChart.Axes(xlValue)                              'グラフX軸について
        .MinimumScale = -20                                     '最少値を-20Cm
        .MaximumScale = 20                                      '最大値を20Cm
        .MinorUnitIsAuto = True                                 '最少目盛は自動
        .MajorUnit = 5                                          '最大目盛を5Cm
        .Crosses = xlAutomatic                                  '交点は自動
        .ReversePlotOrder = False
        .ScaleType = xlLinear
        .DisplayUnit = xlNone
    End With
    
    With ActiveChart.Axes(xlCategory)                           'グラフY軸について
        .MinimumScale = -20                                     '最少値を-20Cm
        .MaximumScale = 20                                      '最大値を20Cm
        .MinorUnitIsAuto = True                                 '最少目盛は自動
        .MajorUnit = 5                                          '最大目盛を5Cm
    End With

    '矩形グラフ
    ActiveChart.SeriesCollection.NewSeries.MarkerStyle = xlMarkerStyleNone     'アクティブグラフに新規グラフを追加
    ActiveChart.SeriesCollection(2).XValues = "='作業用'!$K$12:$K16"            'X値は作業用シートK12からK16
    ActiveChart.SeriesCollection(2).Values = "='作業用'!$L$12:$L$16"            'Y値は作業用シートL12からL16
    ActiveChart.SeriesCollection(2).Points(2).Select                           '新規グラフを選択
    ActiveChart.SeriesCollection(2).ChartType = xlXYScatterLinesNoMarkers      '折れ線グラフでマーカーなし
    ActiveChart.SeriesCollection(2).Name = "矩形"                              '系列名を「矩形」
    
    '中心点ドット
    ActiveChart.SeriesCollection.NewSeries.MarkerStyle = xlMarkerStyleDot     'アクティブグラフに新規グラフを追加
    ActiveChart.SeriesCollection(3).XValues = "='作業用'!$H$12"                'X値は作業用シートH12
    ActiveChart.SeriesCollection(3).Values = "='作業用'!$I$12"                 'Y値は作業用シートI12
    ActiveChart.SeriesCollection(3).Name = "中心点"                           '系列名を「中心点」
    
    With Range("G13:O30")
        ActiveSheet.ChartObjects("グラフ 1").Width = .Width
        ActiveSheet.ChartObjects("グラフ 1").Height = .Height
    End With
    
    
    ActiveChart.HasTitle = True                                 'アクティブグラフのタイトル
    ActiveChart.ChartTitle.Text = "重心動揺計測 単位(cm)"    '「重心動揺計測 単位(cm)」を入力
    ActiveChart.ChartTitle.Font.Size = 16                       'フォントを16ポイント
    
    'プレビューボタンを作る
    ActiveSheet.Buttons.Add(536.25, 6, 42.75, 14.25).Select
    Selection.OnAction = "プレビュー"
    ActiveSheet.Shapes("Button 1").Select
    Selection.Characters.Text = "プレビュー"
    With Selection.Characters(Start:=1, Length:=5).Font
        .Name = "MS Pゴシック"
        .FontStyle = "標準"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone

    End With
    Selection.ShapeRange.ScaleWidth 1.86, msoFalse, msoScaleFromTopLeft
      
    'シート名変更
        Worksheets("作業用").Name = "重心動揺" & Format(Time, "hhnn")
    
        MsgBox "処理が完了しました。", vbOKOnly, "完了"
        Worksheets(1).Select
End Sub

Sub プレビュー()
    ActiveSheet.PageSetup.RightFooter = "Powerd by KITA Ver1.00"
    Range("G1:O36").PrintPreview                                'G1からO40セルの範囲をプレビュー表示

End Sub


-------------------------

やる気マンマンの人はいきなりやってみましょう。




sheet0にデータがある上で、コード先頭の「Sub 空白セル( )」の「S」の字にカーソルを置いて、プレイボタンをクリックする。

もし一覧が表示されてどのマクロを実行するか聞かれたら、「空白セル」を実行してください。









うまくいけば「文字型セル、空白セルはありませんでした。処理を続けます。」と出るので「OK」をクリックすれば、自動ランします。









-------------------------------

つまり、「文字型セル、空白セル」があれば、処理が中止され、そこから進みません。

「文字型セル、空白セル」がどこにあるか、はデータ処理には関係ないので今回ははしょります。
ヒント、どこにあるかは、文字型セルはSUM(その範囲)で参照できないセルを探す。
空白セルはExcel、空白セルでググるといっぱいある。

--------------------------------




「処理が完了しました。」と出て作業完了!











このときVBAじゃなくてExcelのシートのほうに「重心動揺○○○○」というシートができてます。
○のところは処理した時間ね。(何人か計測するとどれだっけ?にならないために)


プレビューボタンで印刷画面もみられます。(ケタが多いとプレビュー出すのも大変だから作ってみた)

例えばコードのRange(A1:B7000)をRange(A1:B5000)に変更すれば、A1:B7000の範囲からA1:B5000の範囲に変更して処理させることができます。処理内容は緑字のコメントに書いてあります。

2013年5月7日追記
カズオさんからのコメントで
「エクセル2002を使い、20秒のデータで計算したかったため、Range(A1:B2000)にしたのですが、空白セルなし→OK→“RangeクラスのSelectメソッドが失敗しました”とエラーメッセージが出てしまいます。」とありました。

ごめんないさい。 
「7000」をイジると、以降のすべての「7000」を修正しないといけないので、そのままでやってください。
もし「7000」より多い「8000」に直すならば、その行以降のすべての「7000」を検索して「8000」に置換してください。(結構たくさんあるのでシンドいです)

今回もボリューム満点だったので、各項目の解説は次回に。



2013年3月8日金曜日

バランスWiiボードとPCで重心動揺計を作る 3


Excelでグラフにする

データがCドライブに入っただけではすぐに使えないし、患者様にお見せできないので、少しの操作でグラフが印刷できるようVBAを組みました。

すること
1 Excelのマクロを使えるようにする。
2 このブログからマクロをコピーしてExcelに貼り付ける。
3 マクロを実行してデータ操作ができるようにする。

まず、今回は 1 Excelのマクロを使えるようにする。

はじめに「開発」 タブを表示する。(すでに「開発」タブが表示されていればこの作業は必要なし)

 (Microsoft Office ボタン をクリックし、[Excel のオプション]をクリックする。

.











[基本設定] をクリックし、
[[開発] タブをリボンに表示する] チェック ボックスをオンにする。








 「開発」タブが表示された。

 「開発」タブをクリックする。










「コードの表示」をクリックする。


「Microsoft Visual Basic」が表示されるので、
「挿入」-「標準モジュール」をクリックする。

すでに「標準モジュール」を組んであるクロートの人はすっ飛ばしてください。
そんな人はココ見ないか・・・






次の「マクロを貼り付ける」のマクロが、ちょっとしたところでつまづいているので、今回はここまで。