VBAについてご教授の程お願い致します。 以下のようなテキストから必要な文字を抜き出し エクセルに表を作成したい…

Question

VBAについてご教授の程お願い致します。

以下のようなテキストから必要な文字を抜き出し
エクセルに表を作成したいと考えております。■テキスト
ここから
***************************
***************************
＜名前＞
AAA
＜年齢＞
20
＜性別＞
男
＜資格＞
自動車免許
危険物取扱主任者
フォークリフト
＜名前＞
BBB
＜年齢＞
30
＜性別＞
女
＜資格＞
自動車免許
介護福祉士
＜名前＞
CCC
＜年齢＞
17
＜性別＞
女
＜資格＞
なし
***************************
***************************

ここまで

上記テキストを以下の様な表にしたいと考えております。
※1行目の項目はエクセルに記入済
2行目以降をテキストから抽出

＜エクセル＞
A B C D
1 名前 年齢 性別 資格
2 AAA 20 男 自動車免許
危険物取扱主任者
フォークリフト
3 BBB 30 女 自動車免許
介護福祉士
4 CCC 17 女 なし
5
6

上記のようなVBAは作成可能でしょうか？
また、抽出対象のテキストはファイル名および保存先が固定ではないため、
ファイルを参照して選択するようなことは可能でしょうか？

Answer 1

「VBScript」でプログラムを組みましたので、「Windows」限定です。

以下のプログラムをメモ帳かテキストエディタに貼り付け、「～.vbs」という名前で保存してください。

「～」の部分は、何でもかまいませんが、「.vbs」は、半角でなければなりません。

プログラムファイルができたら、そのファイルに目的のテキストファイル（「～.txt」）をドラッグ＆ドロップしてください（ドラッグ＆ドロップするファイルは１つだけです）。

４行目に設定したフォルダに、結果が「Result.xlsx」という名前で保存されます。

Option Explicit
Dim a, b, c, d, e, f, i, j, t, u, v, w, x, y, z
Set t = CreateObject("Scripting.FileSystemObject")
Set u = t.GetFolder("D:\Programming")
Set v = WScript.Arguments
If v.Count = 0 then
End If
If v.Count <> 1 Then
MsgBox("ファイルは１つだけです")
WScript.Quit 10
End If
If LCase(Right(v(0), 3)) <> "txt" Then
MsgBox("txtファイルだけです")
WScript.Quit 10
End If
Set w = CreateObject("Excel.Application")
Set x = w.Workbooks.Add()
Set y = x.Worksheets(1)
Set z = t.OpenTextFile(v(0), 1)
a = Split(z.ReadAll, vbCrLf)
z.Close
d = - 1
For i = 0 to UBound(a)
If a(i) = "＜名前＞" Then
d = d + 1
ReDim Preserve n(d)
n(d) = i
End If
If a(i) = "＜年齢＞" Then
ReDim Preserve o(d)
o(d) = i
End If
If a(i) = "＜性別＞" Then
ReDim Preserve s(d)
s(d) = i
End If
If a(i) = "＜資格＞" Then
ReDim Preserve q(d)
q(d) = i
End If
Next
d = d + 1
ReDim Preserve n(d)
n(d) = UBound(a) + 1
For i = 0 to d - 1
y.Cells(i + 1, 1).Value = a(n(i) + 1)
y.Cells(i + 1, 2).Value = a(o(i) + 1)
y.Cells(i + 1, 3).Value = a(s(i) + 1)
e = 3
For j = q(i) + 1 to n(i + 1) - 1
e = e + 1
y.Cells(i + 1, e).Value = a(j)
Next
Next
x.SaveAs(u & "\Result.xlsx")
w.Quit
Set y = Nothing
Set x = Nothing
Set w = Nothing
Set v = Nothing
Set u = Nothing
Set t = Nothing
簡単な説明です。

Set t = CreateObject("Scripting.FileSystemObject")

ファイルやフォルダを扱えるようにしています。

Set u = t.GetFolder("D:\Programming")

この行を質問者の環境に合わせてください。

Set v = WScript.Arguments
If v.Count = 0 then
End If
If v.Count <> 1 Then
MsgBox("ファイルは１つだけです")
WScript.Quit 10
End If
If LCase(Right(v(0), 3)) <> "txt" Then
MsgBox("txtファイルだけです")
WScript.Quit 10
End If

ファイルがドラッグ＆ドロップされるのを待っています。

Set w = CreateObject("Excel.Application")
Set x = w.Workbooks.Add()
Set y = x.Worksheets(1)

エクセルを扱えるようにして、ブックを新規作成し、一番左端のシートを「y」に設定しています。

Set z = t.OpenTextFile(v(0), 1)

ドラッグ＆ドロップしたテキストファイルを開いています。

a = Split(z.ReadAll, vbCrLf)

テキストファイルを一気にすべて読み込んでいますが、「改行」で分割して、配列変数「a」に入れています。

z.Close

テキストファイルを閉じています。

d = - 1
For i = 0 to UBound(a)
If a(i) = "＜名前＞" Then
d = d + 1
ReDim Preserve n(d)
n(d) = i
End If
If a(i) = "＜年齢＞" Then
ReDim Preserve o(d)
o(d) = i
End If
If a(i) = "＜性別＞" Then
ReDim Preserve s(d)
s(d) = i
End If
If a(i) = "＜資格＞" Then
ReDim Preserve q(d)
q(d) = i
End If
Next

各項目が、どこにあるか調べています。

d = d + 1
ReDim Preserve n(d)
n(d) = UBound(a) + 1

プログラムの都合上、最後に１つ足して、「＜名前＞」にしています。

For i = 0 to d - 1
y.Cells(i + 1, 1).Value = a(n(i) + 1)
y.Cells(i + 1, 2).Value = a(o(i) + 1)
y.Cells(i + 1, 3).Value = a(s(i) + 1)
e = 3
For j = q(i) + 1 to n(i + 1) - 1
e = e + 1
y.Cells(i + 1, e).Value = a(j)
Next
Next

エクセルファイルに書き出しているのですが、やっていることは、

「＜名前＞」と「＜年齢＞」の間の行
「＜年齢＞」と「＜性別＞」の間の行
「＜性別＞」と「＜資格＞」の間の行
「＜資格＞」と次の「＜名前＞」の間の行を書き出しています。

x.SaveAs(u & "\Result.xlsx")

エクセルのファイルを「Result.xlsx」という名前で、４行目に設定したフォルダに保存しています。

w.Quit

エクセルを終了しています。

あとは終了処理です。