No.5の回答でVBSでやる方法を教えていただきましたが、
エクセルでマクロボタンを押して
実施できるように変更をしたいです。
どうぞよろしくお願いいたします。
基本的には単純な置き換えで VBS は VBA で動作できるように変更できます。
今回やったのは下記の内容です。
・最初の部分を Sub で囲む。
・WScript.... を代替関数に置き換える。
( WScript.Echo は MsgBox でよいと思います。)
今回のコードだとこんな感じになると思いますが、どうでしょうか。
シートにボタンを配置し InsertTags を割り当ててください。
Option Explicit '--------------------------------------------------------------------- Const INSERT_FILE = "C:\Data\insert.txt" '--- 挿入するファイル名の指定 Const HTML_FOLDER = "C:\HTMLFiles" '--- 変換対象ファイルのフォルダを指定 Const KEY_WORD = "</div>" '--- 検索するタグの指定 Const KEY_COUNT = 13 '--- 検索後の置換して位置 '--------------------------------------------------------------------- Sub InsertTags() Dim fso Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(INSERT_FILE) = False Then MsgBox "挿入データファイル【" & INSERT_FILE & "】がありません: " Exit Sub End If Dim insData insData = fso.OpenTextFile(INSERT_FILE).ReadAll() Dim fCount Dim hFile Dim txtData Dim pos '--- 指定フォルダ内の HTML ファイルを処理 For Each hFile In fso.GetFolder(HTML_FOLDER).Files '--- 拡張子のチェック --- If UCase(fso.GetExtensionName(hFile)) = "HTML" Then txtData = fso.OpenTextFile(hFile.Path).ReadAll() pos = getPos(txtData) If pos > 0 Then If Mid(txtData, pos + 1, 1) = Chr(10) Or Mid(txtData, pos + 1, 1) = Chr(13) Then txtData = Left(txtData, pos) & vbNewLine & insData & Mid(txtData, pos + 1) Else txtData = Left(txtData, pos) & vbNewLine & insData & vbNewLine & Mid(txtData, pos + 1) End If '--- ファイルをバックアップして更新 --- fso.CopyFile hFile.Path, hFile.Path & ".bak" '--- バックアップが不要な場合はこの行を削除 fso.CreateTextFile(hFile.Path, True).Write txtData fCount = fCount + 1 Else '--- タグが指定回数ない MsgBox hFile.Name & ":指定回数の " & KEY_WORD & " がありません。" End If End If Next MsgBox fCount & " 個のファイルを処理しました。" End Sub '--------------------------------------------------------------------- ' 挿入位置の検索 '--------------------------------------------------------------------- Function getPos(txtData) '--------------------------------------------------------------------- Dim sPos Dim dCount sPos = InStr(txtData, KEY_WORD) Do While sPos > 0 dCount = dCount + 1 If dCount = KEY_COUNT Then getPos = sPos + Len(KEY_WORD) - 1 Exit Function End If sPos = InStr(sPos + 1, txtData, KEY_WORD) Loop End Function
Const INSERT_FILE = "C:\Data\insert.txt" Const HTML_FOLDER = "C:\HTMLFiles"
の部分は下記のように書き換えると、セルでファイルやフォルダを指定することができるようにもできます。
Sub InsertTags() Dim INSERT_FILE INSERT_FILE = Range("A1").Value Dim HTML_FOLDER HTML_FOLDER = Range("A2").Value Dim fso Set fso = CreateObject("Scripting.FileSystemObject") : : :
挿入する内容をセルで記載する場合は下記のように修正してください。
Dim insData insData = Range("A1").Value
表示、ツールバー、コントロールツールボックスで ボタンを選択して
画面に貼り付けます。
貼り付けたボタンをダブルクリックして そこに ソースを記述すればいいですよ。
http://www.excel.studio-kazu.jp/lib/e1Ow/e1Ow.html
リストボックスの例
なお エクセルのバージョンによって 出し方が違います。
記述の仕方ですが 以下のようにします。
Private Sub CommandButton1_Click() Dim RetVal RetVal = Shell("wscript.exe ""VBSのフルパス""", 1) End Sub
takntさま
ありがとうございます。
とても参考になりました。
基本的には単純な置き換えで VBS は VBA で動作できるように変更できます。
今回やったのは下記の内容です。
・最初の部分を Sub で囲む。
・WScript.... を代替関数に置き換える。
( WScript.Echo は MsgBox でよいと思います。)
今回のコードだとこんな感じになると思いますが、どうでしょうか。
シートにボタンを配置し InsertTags を割り当ててください。
Option Explicit '--------------------------------------------------------------------- Const INSERT_FILE = "C:\Data\insert.txt" '--- 挿入するファイル名の指定 Const HTML_FOLDER = "C:\HTMLFiles" '--- 変換対象ファイルのフォルダを指定 Const KEY_WORD = "</div>" '--- 検索するタグの指定 Const KEY_COUNT = 13 '--- 検索後の置換して位置 '--------------------------------------------------------------------- Sub InsertTags() Dim fso Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(INSERT_FILE) = False Then MsgBox "挿入データファイル【" & INSERT_FILE & "】がありません: " Exit Sub End If Dim insData insData = fso.OpenTextFile(INSERT_FILE).ReadAll() Dim fCount Dim hFile Dim txtData Dim pos '--- 指定フォルダ内の HTML ファイルを処理 For Each hFile In fso.GetFolder(HTML_FOLDER).Files '--- 拡張子のチェック --- If UCase(fso.GetExtensionName(hFile)) = "HTML" Then txtData = fso.OpenTextFile(hFile.Path).ReadAll() pos = getPos(txtData) If pos > 0 Then If Mid(txtData, pos + 1, 1) = Chr(10) Or Mid(txtData, pos + 1, 1) = Chr(13) Then txtData = Left(txtData, pos) & vbNewLine & insData & Mid(txtData, pos + 1) Else txtData = Left(txtData, pos) & vbNewLine & insData & vbNewLine & Mid(txtData, pos + 1) End If '--- ファイルをバックアップして更新 --- fso.CopyFile hFile.Path, hFile.Path & ".bak" '--- バックアップが不要な場合はこの行を削除 fso.CreateTextFile(hFile.Path, True).Write txtData fCount = fCount + 1 Else '--- タグが指定回数ない MsgBox hFile.Name & ":指定回数の " & KEY_WORD & " がありません。" End If End If Next MsgBox fCount & " 個のファイルを処理しました。" End Sub '--------------------------------------------------------------------- ' 挿入位置の検索 '--------------------------------------------------------------------- Function getPos(txtData) '--------------------------------------------------------------------- Dim sPos Dim dCount sPos = InStr(txtData, KEY_WORD) Do While sPos > 0 dCount = dCount + 1 If dCount = KEY_COUNT Then getPos = sPos + Len(KEY_WORD) - 1 Exit Function End If sPos = InStr(sPos + 1, txtData, KEY_WORD) Loop End Function
Const INSERT_FILE = "C:\Data\insert.txt" Const HTML_FOLDER = "C:\HTMLFiles"
の部分は下記のように書き換えると、セルでファイルやフォルダを指定することができるようにもできます。
Sub InsertTags() Dim INSERT_FILE INSERT_FILE = Range("A1").Value Dim HTML_FOLDER HTML_FOLDER = Range("A2").Value Dim fso Set fso = CreateObject("Scripting.FileSystemObject") : : :
挿入する内容をセルで記載する場合は下記のように修正してください。
Dim insData insData = Range("A1").Value
Mookさま
望みどおりのものができました。
ありがとうございます。
ちなみにですが、
上記でA1にファイルのパスを記入するやり方を
教えていただきましたが、
実際にA1の内容を挿入することはできますでしょうか?
どうぞよろしくお願いいたします。
Mookさま
望みどおりのものができました。
ありがとうございます。
ちなみにですが、
上記でA1にファイルのパスを記入するやり方を
教えていただきましたが、
実際にA1の内容を挿入することはできますでしょうか?
どうぞよろしくお願いいたします。