現在フォルダに入っているtxtファイルのデータで、抜き出したいデータを正規表現で順番に抜き出す作業をしたいと考えています。
しかし、自分の力では現在スクリプトを作成できない状況です。やや緊急で大変お手数をおかけしますがスクリプトを作成していただける方おりましたら作成していただけないでしょうか
スクリプト手順ですが
①フォルダを指定する
②指定されたフォルダにあるテキストを名前が若い番号から順に開いて正規表現していく。
③必要データの抜き取り
列Aにtxtファイルの名前(.txtの前の値)を入れる。
列Bにtxtファイルに書いてある 生産国: ★値★ <br>の値の部分を抜き出し書き込み。
列Cにtxtファイルに書いてある 素材・色 : ★値★ <br>の値の部分を抜き出し書き込み。
列Dにtxtファイルに書いてある サイズ : ★値★ <br>の値の部分を抜き出し書き込み。
これをファイルが入っている所までやりたいと考えているのですが
回答できるかたおりましたらご回答いただければと考えております。
よろしくお願いいたします。
どなたからも回答がなかったので、久しぶりに作ってみました。
なお、文章が一部不明だったので、次のように捉えました。
②(丸2):「名前が若い番号から順に開いて正規表現していく。」
→ファイル名昇順でリストに作る(処理の都合上、この処理は最後に行った)
パターン:
「素材・色 : ★値★ <br>の値の部分を抜き出し」
→ キーワード 半角・全角ブランクが0-n個 : 半角・全角ブランクが0-n個 その後が値 <br> とみなした
もし、常に★で囲まれているのであれば、パターンの(.*?)を★で囲んでください。あっ、その後に空白があってから<br>であれば、そのように変更ください。
Option Explicit Const ForReading As Integer = 1 ' FSO Const sColFile As String = "A" ' カラム定義 Const sColCountry As String = "B" Const sColColor As String = "C" Const sColSize As String = "D" Const sCountry As String = "生産国[ ]*:[ ]*(.*?)<br>" Const sColor As String = "素材・色[ ]*:[ ]*(.*?)<br>" Const sSize As String = "サイズ[ ]*:[ ]*(.*?)<br>" Sub SearchValue() Dim sPath As String Dim vName As Variant Dim fs As Object, ts As Object Dim sBuf As String Dim lnRow As Long Set fs = CreateObject("Scripting.FileSystemObject") sPath = InputBox("フォルダ名") If sPath = "" Then Exit Sub sPath = sPath & "\" vName = Dir(sPath & "*.txt") ' 最初のファイル lnRow = 1 Do While vName <> "" Set ts = fs.OpenTextFile(sPath & vName, ForReading) sBuf = ts.ReadAll ts.Close ' 正規表現でファイル中から探してセルへ設定 Cells(lnRow, sColFile) = Left(vName, Len(vName) - 4) Cells(lnRow, sColCountry) = sReg(sBuf, sCountry) Cells(lnRow, sColColor) = sReg(sBuf, sColor) Cells(lnRow, sColSize) = sReg(sBuf, sSize) vName = Dir ' 次のファイル lnRow = lnRow + 1 Loop Range(sColFile & "1" & ":" & sColSize & (lnRow - 1)).Sort _ Key1:=Range(sColFile & "1") '並べ替え End Sub Function sReg(strTrg As String, sPattern As String) As String Dim re As Object Dim mc As Object Set re = CreateObject("VBScript.RegExp") With re .Pattern = sPattern .MultiLine = True .IgnoreCase = True Set mc = .Execute(strTrg) End With If mc.Count >= 1 Then sReg = mc(0).SubMatches(0) Else sReg = "" End If End Function
P.S.以前も記載しましたが、一冊VBAの本を買っておくといいと思います。
どなたからも回答がなかったので、久しぶりに作ってみました。
なお、文章が一部不明だったので、次のように捉えました。
②(丸2):「名前が若い番号から順に開いて正規表現していく。」
→ファイル名昇順でリストに作る(処理の都合上、この処理は最後に行った)
パターン:
「素材・色 : ★値★ <br>の値の部分を抜き出し」
→ キーワード 半角・全角ブランクが0-n個 : 半角・全角ブランクが0-n個 その後が値 <br> とみなした
もし、常に★で囲まれているのであれば、パターンの(.*?)を★で囲んでください。あっ、その後に空白があってから<br>であれば、そのように変更ください。
Option Explicit Const ForReading As Integer = 1 ' FSO Const sColFile As String = "A" ' カラム定義 Const sColCountry As String = "B" Const sColColor As String = "C" Const sColSize As String = "D" Const sCountry As String = "生産国[ ]*:[ ]*(.*?)<br>" Const sColor As String = "素材・色[ ]*:[ ]*(.*?)<br>" Const sSize As String = "サイズ[ ]*:[ ]*(.*?)<br>" Sub SearchValue() Dim sPath As String Dim vName As Variant Dim fs As Object, ts As Object Dim sBuf As String Dim lnRow As Long Set fs = CreateObject("Scripting.FileSystemObject") sPath = InputBox("フォルダ名") If sPath = "" Then Exit Sub sPath = sPath & "\" vName = Dir(sPath & "*.txt") ' 最初のファイル lnRow = 1 Do While vName <> "" Set ts = fs.OpenTextFile(sPath & vName, ForReading) sBuf = ts.ReadAll ts.Close ' 正規表現でファイル中から探してセルへ設定 Cells(lnRow, sColFile) = Left(vName, Len(vName) - 4) Cells(lnRow, sColCountry) = sReg(sBuf, sCountry) Cells(lnRow, sColColor) = sReg(sBuf, sColor) Cells(lnRow, sColSize) = sReg(sBuf, sSize) vName = Dir ' 次のファイル lnRow = lnRow + 1 Loop Range(sColFile & "1" & ":" & sColSize & (lnRow - 1)).Sort _ Key1:=Range(sColFile & "1") '並べ替え End Sub Function sReg(strTrg As String, sPattern As String) As String Dim re As Object Dim mc As Object Set re = CreateObject("VBScript.RegExp") With re .Pattern = sPattern .MultiLine = True .IgnoreCase = True Set mc = .Execute(strTrg) End With If mc.Count >= 1 Then sReg = mc(0).SubMatches(0) Else sReg = "" End If End Function
P.S.以前も記載しましたが、一冊VBAの本を買っておくといいと思います。
ご回答ありがとうございます。
windowsに標準装備されているコマンドプロンプトでやるとカンタンですよ。
しかも、スクリプトをかくのもテキストファイルに書いて、拡張子をbatにして保存するだけです。
バッチファイルの命令文
ご回答ありがとうございます。
ご回答ありがとうございます。