http://q.hatena.ne.jp/1240142055の質問で

No.5の回答でVBSでやる方法を教えていただきましたが、
エクセルでマクロボタンを押して
実施できるように変更をしたいです。

どうぞよろしくお願いいたします。

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2011/08/30 09:20:29
  • 終了:2011/08/30 16:15:38

ベストアンサー

id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912011/08/30 12:45:09

ポイント500pt

基本的には単純な置き換えで 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
id:ohtsu6

Mookさま

望みどおりのものができました。

ありがとうございます。

ちなみにですが、

上記でA1にファイルのパスを記入するやり方を

教えていただきましたが、

実際にA1の内容を挿入することはできますでしょうか?

どうぞよろしくお願いいたします。

2011/08/30 13:32:50

その他の回答(2件)

id:taknt No.1

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/08/30 09:37:04

ポイント100pt

表示、ツールバー、コントロールツールボックスで ボタンを選択して

画面に貼り付けます。

貼り付けたボタンをダブルクリックして そこに ソースを記述すればいいですよ。


http://www.excel.studio-kazu.jp/lib/e1Ow/e1Ow.html

リストボックスの例

なお エクセルのバージョンによって 出し方が違います。

id:taknt No.2

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/08/30 12:30:15

記述の仕方ですが 以下のようにします。

Private Sub CommandButton1_Click()
Dim RetVal
    RetVal = Shell("wscript.exe ""VBSのフルパス""", 1)
End Sub
id:ohtsu6

takntさま

ありがとうございます。

とても参考になりました。

2011/08/30 16:14:40
id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912011/08/30 12:45:09ここでベストアンサー

ポイント500pt

基本的には単純な置き換えで 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
id:ohtsu6

Mookさま

望みどおりのものができました。

ありがとうございます。

ちなみにですが、

上記でA1にファイルのパスを記入するやり方を

教えていただきましたが、

実際にA1の内容を挿入することはできますでしょうか?

どうぞよろしくお願いいたします。

2011/08/30 13:32:50
  • id:ohtsu6
    >takntさま
    早々にありがとうございます。
    そのまま貼り付けたらプロシージャ内では無効ですと出てしまいました・・・

    何が原因でしょうか?
  • id:Mook
    回答にコメントいただいた件は、回答の末尾に追記しました。
  • id:ohtsu6
    Mookさま
    できました。
    どうもありがとうございました。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません