こんにちは。最近仕事でVBAと戯れている者です。

さて、先日開発中の業務システムのHTMLファイルから「width属性が含まれる文字列だけを抽出する」作業を依頼されました。

そのHTMLファイルの総件数が余裕で100件を超えるものだったため、「やってられっかー！」と思いVBAでツールを作った次第です。

せっかく作ったものなので、こちらに投稿して評価してもらいたいなという下心もありつつ、執筆していこうかと思います！

#環境

Windows10
Excel2016
対象ファイル：.htmlファイル

↓htmlファイルの中身はめちゃくちゃ適当に書くとこんな感じ。

sample.html

<!DOCTYPE html>
<html>
  <head>
    <title>ページタイトル</title>
  </head>
  <body>
    <h2 style = width:100px;>AAA</h2>
    <p class = XXX>BBB</p>
    ・
    ・
    ・
  </body>
</html>

このようなhtmlファイルの中身から、「width属性」を含む文字列だけ抜き出します。

上記ファイルの場合だと<h2>タグの文字列が対象になりますね。

#事前準備
このあと実行コードを記載しますが、事前準備としてExcelシートに対象ファイルのパスを貼り付けておく必要があります。

ファイルパスは、例えば「D:¥共通¥サンプル1.html」といった感じですね。

今回は「Sheet3」シートにファイルパスを書き出しました。

この状態で準備できればOKです。

#実行コードの全容はこちら
実行コードの全容を記載します。

一応全てのコードにコメントを記載しています（読みづらかったらすみません・・・！）。

Sub html_width_search()

    'マクロの速度を向上させるため､画面を更新しないようにする
    Application.ScreenUpdating = False

    '変数一覧
    Dim fPath As Variant
    Dim FSO As Object
    Dim sBuf As String
    Dim n As Long
    Dim k As Long
    Dim t1 As Long
    Dim t2 As Long
    Dim tmpBuf As String
    Dim ary()
    Dim i As Long
    Dim r As Long: r = 2
    Dim reg As Object
    
    'テキストの正規表現用
    Set reg = CreateObject("VBScript.RegExp")
    With reg
        .Pattern = ".*¥¥"
        .IgnoreCase = False
        .Global = True
    End With
    
    '予め別シートに用意しておいたファイルパス一覧を配列に格納する
    fPath = Sheets(3).Range("A1:A100").Value
    
    'fPathに格納した要素の数だけ繰り返す
    For n = LBound(fPath, 1) To UBound(fPath, 1)

        'ファイルの中身が空だった場合"CONTINUE:"の位置までジャンプする
        If FileLen(fPath(n, 1)) = 0 Then GoTo CONTINUE
        
        'ファイルやフォルダの作成、削除、移動、コピーといった基本操作を扱えるオブジェクト
        Set FSO = CreateObject("Scripting.FileSystemObject")

        'htmlファイルのテキスト取得
        With FSO.GetFile(fPath(n, 1)).OpenAsTextStream
            sBuf = .ReadAll
            .Close
        End With
        
        'htmlファイルからテキストを一行ごとに配列に格納
        t1 = 1
        k = 0
        Do
            t2 = InStr(t1, sBuf, vbCrLf)'vbCrLf = 改行
            If t2 = 0 Then Exit Do
            tmpBuf = Mid(sBuf, t1, t2 - t1 + 2)
            t1 = t2 + 2
    
            ReDim Preserve ary(k)
            ary(k) = tmpBuf
            k = k + 1
        Loop

        '「width」が入っていない文字列をEmpty値にする
        For i = 0 To UBound(ary)
            If Not ary(i) Like "*width*" Then
                ary(i) = Empty
            End If
        Next i
        
        'Call_Array_DeleteEmptyを呼び出す（Empty値を削除するため）
        For i = 0 To UBound(ary)
            '配列の要素にEmpty以外があれば、呼び出す
            If Not IsEmpty(ary(i)) Then
                ary = Call_Array_DeleteEmpty(ary)
                Exit For
            End If
        Next i
        
        'Call_Array_DeleteEmptyで再定義した配列の数だけ対象シートのセルに貼り付け
        For i = 0 To UBound(ary)
            'Empty値が見つかった場合、貼り付け中断
            If IsEmpty(ary(i)) Then Exit For
        
            '余計な改行を削除
            If InStr(ary(i), vbCrLf) <> 0 Then
                ary(i) = Replace(ary(i), vbCrLf, "")
            End If
            
            'ファイル名と該当箇所の文字列を貼り付け
            Sheets(2).Cells(r + i, 1) = reg.Replace(fPath(n, 1), "")
            Sheets(2).Cells(r + i, 2) = ary(i)
        Next i
    
        '次に貼り付けをスタートさせる行を指定
        r = r + i
        
        '配列を初期化
        Erase ary
        
CONTINUE:
           
    Next
    
    '後片付け
    Set FSO = Nothing
    
    'メッセージボックスの表示
    MsgBox "htmlファイルの一覧を作成しました", vbInformation
    
    '画面更新を許可する
    Application.ScreenUpdating = True
    
End Sub

'--------------------------------------------------------------------

'配列からEmptyと空文字列("")を削除する
Public Function Call_Array_DeleteEmpty(arr As Variant)

    '変数一覧
    Dim i As Long
    Dim temp As Variant
    Dim tRow As Variant
    
    '再定義
    ReDim temp(UBound(arr))
     
    For Each tRow In arr
       'tRowが空白以外であれば、temp配列に格納する
       If Not IsEmpty(tRow) And Not tRow = "" Then
          temp(i) = tRow
          i = i + 1
       End If
    Next

    '"temp"を空白を除いた分で再定義
    ReDim Preserve temp(i - 1)
    
    Call_Array_DeleteEmpty = temp

End Function

#振り返ってみて

例外処理も書いておけば良かったなぁと思いましたが、限られた時間でそこまで配慮するスキルもありませんでした。

リファクタリングは今後学んでいく必要がありそう・・・。

ただ、業務ツールは作ってて楽しいなぁと感じましたし、またチャレンジしたいですね。

「楽をするためにはどうするか？」というエンジニアらしい思考になってきたのではないでしょうか。