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

Excelでグラフにする　２

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


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

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

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

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

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

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

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

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

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

－－－－－－－－－－－－－－－－－－－－－－－－－

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 = "ＭＳ Ｐゴシック"
        .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」に置換してください。（結構たくさんあるのでシンドいです）

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