Excel VBA Sars-Covid-19用健康観察シート

Excel 2013 Later

テーマを設定するので2013以降です。

医学的正確さは保証しない

基本これだけでは足りないのと、現在2022/08の知見が正確とも限らないので全くわかりません。
単純に健康観察自体は4週間続けたほうが良いとされているので、それを書き込むという目的のためです。
この様式は中等症用には明らかに情報が不足しているので、症状が重い場合には別の様式を使う必要があります。

図る時間

AM 起床時 または7：30
PM 夕食前 または17：00
夜　就寝前
だいたいこれくらいを目安にします。
ただし、熱がある場合ときはその時計り、時刻を記録してください。絶対に葛根湯や解熱剤、鎮痛剤を飲んでから測るのはやめましょう。飲んでからも測るのは飲む時刻と量、その前後の体温を測るのでなければ意味がありません。最も熱があるときは忘れるかもしれません。その時はその旨記録しましょう。

補足として

この他、飲んだ薬を書き込みましょう。
この他、血圧も必要でしょう。
さらに体重も計測してください。
4週間と言わず続けたほうがいいです。
更にいうと平素から計測しましょう。体温、SPO2、体重はしないほうがおかしいのです。欲をえ言えば血圧です。

オミクロンに特異的な症状として

現在夏風邪との区別がつかないと言われているようにBA4.BA5,BA2.75の主症状はイギリスのデータでは喉の痛みです。
嗅覚異常、味覚異常の発言の率は下がっていますが、このほか、筋肉痛、次に発熱とは逆に体温が下がる場合があります。
咳についてはたんが出るか出ないかも（日頃出にくいかどうかを含め）記録してください。
また、目の痛み、声がかすれる。鼻声のまま治らないという場合もあります。
つばを飲み込めないような強いのどの痛みがあるときや、息を吸うのが苦しいとき、声がこもったようになっているとき
これはオミクロンバリアント、「上気道において増殖する」(https://www.pref.yamagata.jp/documents/28395/siryou2.pdf)という特徴を持っているためであると考えられます。ただしリンク先のようにだから飛沫感染しやすいとか大間違いで（だったら今までの株は空気感染じゃないか）エアロゾルでもマイクロ飛沫でもなく、純粋な空気感染（Airborn Transmission）です。いくら対策しても効かないのは空気感染を前提としていないからですね。全数検査を止めますとかいう以前の問題。上気道だったらなぜ飛沫感染なのか、一切説明がないですね。
それはさておき、どうみても風邪のような症状でも記録して発熱外来に相談しましょう。
なお、オミクロンは死亡率が低いと言われていますが、長期間観察したデータは存在しないため、死亡率が低いということは現時点では言えないと思います。サイトカインバーストを起こさないということは免疫系統をより高度に騙して心筋炎に持ち込むことが考えられるからです。以上からコロナだという前提で記録しましょう。

パルスオキシメーター自体は適当なものでよい

パルスオキシメーターは特に安くてもいいです。医療機器だろうとそういう認証が無かろうとあまり差は出ないようです。
これはパルスオキシメーターの原理が単純なためです。
ただし計り方は手が冷たいときは指を温める。
起床して座った状態で行う。寝ていると少なくなる。爪を上に、15秒以上安定した数字を採用しましょう。
こうした基本は守って当たり前です。

体温計

　体温計は電子体温計オムロンが推奨です。テルモはセンサーが短くて計測が不安定です。
　コンビニで売るだけあってオムロンは正直ど素人相手を想定しており、正確な腋中温度を図らず、温度分布から一番高いところを腋中温度としている可能性が高いです。
　なぜそんなことがわかるかというと、テルモに比べてセンサー部分が大きいためです。
　しかし、プロは腋中を外さないので、それは逆に不正確なのでテルモを使うわけです。
　ここで素人とプロの埋めがたい差が生じます。
また、消毒とか面倒なので家族分買ってください。

血圧も記録しよう

そもそもバイタルの基本は血圧、体温なので、血圧も記録しましょう
プラスすると意識レベルや脈拍、呼吸ですが、やり過ぎるとあきるのでおすすめできません。

Version

1.1と課題

右側の計算が印刷されない問題に対応しました。
コメントが何故かシートの末尾に印刷される場合がありますが、そこのSleepをかけて変更させるようにしましたが、効くときと効かないときがあります。
Application.Waitは有効ではないようです。
Sleepを前後にかけると成功しますが、しないときもあります。
このため印刷する時プレビューでページ数が1ページであることを確認して印刷してください。

コード的な新味なし

' ********
' * Win 32 API *
' ********
#If VBA7 Then
  Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
  Private Declare  Sub MSleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
#End If

' ********
' * Main *
' ********
Sub MakeCovidSelfCheckSheet()
' For Microsoft Excel Ver 15 Later
' Ver 1.0
' 汎用様式とするため、2010までのテーマに
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ar
' Theme setting Office 2007-2010
Dim sThem As String, sThemeFolder As String, FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
              sThemeFolder = FSO.GetParentFolderName(Application.Path) & "\Document Themes " & CInt(Application.Version) & "\"
               sThem = "Office Theme.thmx"
               wb.ApplyTheme (FSO.BuildPath(sThemeFolder, sThem))
               sThem = "Office 2007 - 2010.xml"
               wb.Theme.ThemeFontScheme.Load FSO.BuildPath(sThemeFolder & "\Theme Fonts", sThem) 'Fonts
               wb.Theme.ThemeColorScheme.Load FSO.BuildPath(sThemeFolder & "\Theme Colors", sThem) 'Colors
               sThem = "Office 2007 - 2010.eftx"
               wb.Theme.ThemeEffectScheme.Load FSO.BuildPath(sThemeFolder & "\Theme Effects", sThem)
Set FSO = Nothing
  

    With Range("A1")
    .Value = "Self Check Sheet for Sars-Covd-19"
    .Font.Size = 16
    .Font.Bold = True
    End With
' Hispeed
HighSpeed = True

    Range("H1").Value = "Ver1.1"
' ColumnWidth And RowHeight
    Rows("1:1").RowHeight = 18.75
    Rows("2:2").RowHeight = 14.25
    Rows("3:3").RowHeight = 14.25
    Rows("4:4").RowHeight = 14.25
    Rows("5:5").RowHeight = 14.5
    Range("A1").Select
    Columns(1).ColumnWidth = 14.63
    Columns(2).ColumnWidth = 6.63
    Columns(3).ColumnWidth = 7.88!
    Columns(4).ColumnWidth = 6.5!
    Columns(5).ColumnWidth = 4.86!
    Columns(6).ColumnWidth = 6!
    Columns(7).ColumnWidth = 6.63!
    Columns(8).ColumnWidth = 4.63!
    Columns(9).ColumnWidth = 12.25
' DropDown List
Range("K5") = "AM"
Range("K6") = "PM"
Range("K7") = "夜"
Range("L5").Value = "ある"
Range("L6").Value = "少し"
Range("L7").Value = "なし"
ar = Split("陽性診断日,発症日,氏名", ",")
Dim icol As Long, irow As Long, DT As Date, iar As Long
irow = 2
For iar = LBound(ar) To UBound(ar)
Cells(irow, 1) = ar(iar)
Cells(irow, 1).Select
With Selection
.Font.Size = 10
.Offset(0, 1).Font.Size = 10
.Offset(0, 2).Font.Size = 10
.Offset(0, 3).Font.Size = 10
.Offset(0, 4).Font.Size = 10
End With
irow = irow + 1
Next
Range("B2:C2").Select
With Selection
.Merge
End With
With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
   .NumberFormatLocal = "[$-x-sysdate]dddd, mmmm dd, yyyy"
End With
Range("B3:C3").Select
With Selection
.Merge
End With
With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
   .NumberFormatLocal = "[$-x-sysdate]dddd, mmmm dd, yyyy"
End With
Range("E4").Value = "性別"
Range("G4").Value = "年齢"
Range("A5").Value = "健康観察実施日"
Range("B5").Value = "時間帯"
Range("C5").Value = "時間"
Range("D5").Value = "体温"
Range("E5").Value = "SpO2"
Range("F5").Value = "息苦しさ"
Range("G5").Value = "咳"
Range("H5").Value = "倦怠感"
Range("I5").Value = "その他の症状"
Range("I5").ClearComments
With Range("I5").AddComment
.Visible = True
.Text Text:="関節痛、意識混濁、鼻水、喉が痛い、たんが出る、下痢、脈が飛ぶ、悪寒"
.Visible = False
End With
Range("A5:i5").HorizontalAlignment = xlCenter
Range("A5:i5").Font.Size = 10
For icol = 1 To 9
Call SelectRangeLine(Range(Cells(5, icol).Address))
Next
For irow = 6 To 26
Rows(irow).RowHeight = 31.5
For icol = 1 To 9
Call SelectRangeLine(Range(Cells(irow, icol).Address))
Next
Call FormatNumberLocalSet(irow)
Next
    Range("A5:A26").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
    
' Page Setup
    With ActiveSheet.PageSetup
        .PrintTitleRows = "1：5"
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftMargin = Application.CentimetersToPoints(2.5!)
        .RightMargin = Application.CentimetersToPoints(2.5!)
        .TopMargin = Application.CentimetersToPoints(3!)
        .BottomMargin = Application.CentimetersToPoints(2.5!)
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .PrintArea = "$A$1:$I$26"
         Sleep 1000
         If .PrintComments <> xlPrintNoComments Then
            .PrintComments = xlPrintNoComments
         End If
         Sleep 1000
         If ActiveSheet.PageSetup.PrintNotes = True Then
            ActiveSheet.PageSetup.PrintNotes = False
         End If
         Sleep 1000
    End With
Range("A1").Select
ActiveWindow.Zoom = 100
ActiveWindow.View = xlPageBreakPreview
HighSpeed = False
End SubSub SetValidation1(r As Range)
r.Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=$K$5:$K$7"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeOff
        .ShowInput = True
        .ShowError = False
    End With
End Sub
Sub SetValidation2(r As Range)
r.Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=$L$5:$L$7"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeOff
        .ShowInput = True
        .ShowError = False
    End With
End Sub
Property Let HighSpeed(flag As Boolean)
Dim i As Long
Application.ActiveWindow.DisplayGridlines = Not flag 'Strength ver 1.1
Application.ScreenUpdating = Not flag
Application.DisplayAlerts = Not flag
Application.PrintCommunication = Not flag 'Strength ver 1.1
i = ActiveWindow.Zoom
If flag Then
Application.Calculation = xlCalculationManual
Else
Application.Calculation = xlCalculationAutomatic
ActiveWindow.Zoom = 100
End If
End Property