MAPS-TP in いきいき館 11月5日(水/AM)の予定…家計簿77拡張

 「家計簿で血圧等を入力したい」という要望に対応するため、各自が持っている歩数・血圧等をレイアウトを変更し、家計簿に取り込む。

  1. 血圧や歩数の記録は、各自でスタート時期が異なる(たぶん)ので、データが 1ヶ月分以上ある方を優先する。
    • 個人個人でレイアウトが異なるはずなので、統一して家計簿に「新しいシート」を作成する。
    • データが少ないとグラフのイメージが固まらない...
  2. 新しい関数(VLookup)を使うことになる。(たぶん)
§1.対応方法(予定)
  1. 新しいシートを作成し、下記 §2.の項目を入力する。
  • 家計簿の中でグラフを作ることは、家計簿を壊すリスクがあるので行わない。
     代わりに、グラフデータを別ブックに書き出す。(ブック名:家計簿77グラフデータ の予定)
§2.入力する項目と並び

  1. No. ‥‥ 入力不要。収支シートと合わせるための設けた。
  2. 年月日 ‥‥ 発生日。
    • 今は、重複は無いことを前提にしている。
    • 血圧値等を複数回入力するのであれば、入力を 年月日時分(例えば、2014/11/1 7:00)にすれば可能だが...
  3. 歩数
  4. 体重
  5. 体温
  6. 上血圧
  7. 下血圧
  8. 脈拍
  9. 備考
  • 項目名は任意。説明の都合を考えると、統一した方がよい。
  • 入力し易い順にしておくのがベスト。
  • 項目名はマクロの中では使わない。使うのは列番号なので、一度決めたら並びは変えられない。
§3.シート名

 “歩数血圧” を予定している。
一度決めたら変更は不可。(マクロの中で使うため)

§4.既存データのつなぎ込み

 個々に異なるので、個別対応となる。
作ってあるマクロは下記。但し、ケースバイケースで変える...
≪歩数血圧マクロ.xlsm≫

  1. Sub a4_日付重複チェック()
  2. '日付順にならんでいる前提。
  3. Dim mbTitle As String
  4. Dim oldDate As Date
  5. Dim chofukuCtr As Long
  6. Dim r As Long, lastRow As Long
  7.  
  8. mbTitle = "日付重複チェック/" & ThisWorkbook.Name
  9. lastRow = Cells(Rows.Count, 2).End(xlUp).Row
  10. chofukuCtr = 0
  11. For r = 2 To lastRow
  12. If r = 2 Then
  13. oldDate = Cells(r, 2)
  14. Else
  15. If Cells(r, 2) = oldDate Then
  16. Range(Cells(r - 1, 2), Cells(r, 2)).Select
  17. MsgBox "日付が重複しています!", vbExclamation, mbTitle
  18. chofukuCtr = chofukuCtr + 1
  19. Else
  20. oldDate = Cells(r, 2)
  21. End If
  22. End If
  23. Next
  24. MsgBox chofukuCtr & "件 日付が重複していました。", vbInformation, mbTitle
  25.  
  26.  
  27. End Sub


 

  1. Sub a3_空行を削除する()
  2. Dim mbTitle As String
  3. Dim isDelete As Boolean
  4. Dim c As Long, r As Long, lastRow As Long
  5. Dim deleteCtr As Long
  6.  
  7. mbTitle = "空行を削除する/" & ThisWorkbook.Name
  8. lastRow = Cells(Rows.Count, 2).End(xlUp).Row
  9. deleteCtr = 0
  10. For r = lastRow To 2 Step -1
  11. isDelete = True
  12. For c = 3 To 9
  13. If Cells(r, c) <> "" Then isDelete = False: Exit For
  14. Next
  15. If isDelete Then
  16. Rows(r).Select
  17. MsgBox "削除します!", vbExclamation, mbTitle
  18. Rows(r).Delete: deleteCtr = deleteCtr + 1
  19. End If
  20. Next
  21. MsgBox deleteCtr & "件 削除しました。", vbInformation, mbTitle
  22.  
  23. End Sub


 

  1. Sub a2_結合する()
  2. Dim mbTitle As String
  3. Dim i As Long, c As Long
  4. Dim lastRow As Long
  5. Dim oldDate As Date
  6.  
  7. mbTitle = "結合する/" & ThisWorkbook.Name
  8. lastRow = Cells(Rows.Count, 2).End(xlUp).Row
  9. For i = 2 To lastRow
  10. Range("B" & i).Select
  11. Do   'dummy
  12. If i = 2 Then oldDate = Cells(i, 2): Exit Do
  13. If Cells(i, 2) <> Cells(i - 1, 2) Then oldDate = Cells(i, 2): Exit Do
  14. Union(Rows(i - 1), Rows(i)).Select
  15. MsgBox "結合します1", vbExclamation, mbTitle
  16. '歩数〜脈拍
  17. For c = 3 To 8
  18. If Cells(i, c) <> "" Then
  19. If Cells(i - 1, c) = "" Then
  20. Cells(i - 1, c) = Cells(i, c): Cells(i, c) = ""
  21. Else
  22. MsgBox "結合できません!", vbCritical, mbTitle
  23. Stop
  24. End If
  25. End If
  26. Next
  27. '備考
  28. If Cells(i, 9) <> "" Then
  29. If Cells(i - 1, 9) = "" Then
  30. Cells(i - 1, 9) = Cells(i, 9): Cells(i, 9) = ""
  31. Else
  32. Cells(i - 1, 9) = Cells(i - 1, 9) & "/" & Cells(i, 9): Cells(i, 9) = ""
  33. End If
  34. End If
  35. Exit Do
  36. Loop
  37. Next
  38.  
  39. End Sub


 

  1. Sub a1_並べ替える()
  2. Dim lastRow As Long
  3.  
  4. lastRow = Cells(Rows.Count, 2).End(xlUp).Row
  5. ActiveWorkbook.Worksheets("歩数血圧録").Sort.SortFields.Clear
  6. ActiveWorkbook.Worksheets("歩数血圧録").Sort.SortFields.Add Key:=Range("B2:B" & lastRow) _
  7. , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  8. ActiveWorkbook.Worksheets("歩数血圧録").Sort.SortFields.Add Key:=Range("C2:C" & lastRow) _
  9. , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  10. With ActiveWorkbook.Worksheets("歩数血圧録").Sort
  11. .SetRange Range("A1:I" & lastRow)
  12. .Header = xlYes
  13. .MatchCase = False
  14. .Orientation = xlTopToBottom
  15. .SortMethod = xlPinYin
  16. .Apply
  17. End With
  18.  
  19. End Sub