こんにちは。最近仕事で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
#振り返ってみて
例外処理も書いておけば良かったなぁと思いましたが、限られた時間でそこまで配慮するスキルもありませんでした。
リファクタリングは今後学んでいく必要がありそう・・・。
ただ、業務ツールは作ってて楽しいなぁと感じましたし、またチャレンジしたいですね。
「楽をするためにはどうするか？」というエンジニアらしい思考になってきたのではないでしょうか。