まりふのひと

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

infor MAPS-BB

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

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

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

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

§４．既存データのつなぎ込み

　個々に異なるので、個別対応となる。
作ってあるマクロは下記。但し、ケースバイケースで変える...
≪歩数血圧マクロ.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 "結合します１", 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