ExcelVBAを使い、電子カルテの情報をExcelシートに転記

久しぶりのVBAネタです。業務効率化を図る一環として、電子カルテの情報をExcelシートに効率よく貼り付けられないか模索中です。ただペーストするだけでなく、氏名は氏名のセルへ、年齢は年齢のセルへ、勝手に判断して貼り付けてくれたら理想です。できるかなって思ってやってみると、意外とあっさりできました。

できたコードが以下の通り。

Sub SelectPaste()

    'Microsoft Forms 2.0 Object Libraryを参照設定
    Dim myDobj As New DataObject
    Dim myVar As Variant
    Dim myRange As Range
    Dim iVar As Variant
    Dim jRange As Range
    Dim myStr As String

    'ペーストする対象セル範囲を設定
    Set myRange = Range("A1:H20")

    'クリップボード内容を、改行で分けて配列に格納
    With myDobj
        .GetFromClipboard
        myVar = Split(.GetText, vbLf)
    End With

    '文字列の配列をループ
    For Each iVar In myVar
        If InStr(iVar, "：") > 0 Then
        
            '検索対象のrangeをループ
            myStr = Left(iVar, InStr(iVar, "："))
            For Each jRange In myRange
                If InStr(jRange.Value, myStr) > 0 Then
                    jRange.Value = iVar
                End If
            Next
            
        End If
    Next

End Sub

コピー元の情報は、こんな感じに項目、コロン、内容、と並んでいる
入院日：平成30年5月7日
名前：〇〇　××
年齢：68歳
性別：男性

DataObjectを使うので、Microsoft Forms 2.0 Object Libraryの参照設定が必要。

 Set myRange = Range("A1:H20")

ここで探す対象セル範囲を設定。

  With myDobj
        .GetFromClipboard
        myVar = Split(.GetText, vbLf)
    End With

これでコピーしたテキストデータをいったんDataObjectに取り込み、改行で分割して、配列としてmyVarに取り込む。

    For Each iVar In myVar
        If InStr(iVar, "：") > 0 Then

まずは、For EachでmyVarの配列各要素でループする。2行目がないと、空白行があった場合おかしな挙動になる。

            myStr = Left(iVar, InStr(iVar, "："))
            For Each jRange In myRange
                If InStr(jRange.Value, myStr) > 0 Then
                    jRange.Value = iVar
                End If
            Next

ここが一番のキモ。myStrに”：”より左側の文字列、要するに項目名を取り込み、myRangeの各セルをループする。セルに、同じ項目名文字列を見つけたら、電子カルテから取り込んだ項目情報を書き込む。

以外に簡単にできた。いろいろ応用できそう。