エクセルVBAについて質問です。次のページにあるようなマクロを作ってください。

http://hatena88.web.fc2.com/hatena/newpage2.shtml
なお、現在勉強中ですので、下記の質問の回答者4の方のような解説を付け加えていただいた方には追加ポイントのおまけを付けます。もしそれが必要なければマクロだけでも結構です。よろしくお願いします。
http://q.hatena.ne.jp/1158311664

回答の条件
  • URL必須
  • 1人2回まで
  • 登録:2006/10/30 23:29:44
  • 終了:2006/10/31 15:20:44

回答(2件)

id:bonlife No.1

回答回数421ベストアンサー獲得回数752006/10/31 00:15:35

ポイント10pt

こんな感じでいかがでしょうか。

内容はほとんど同じなのでコメントは一部のみにいたしました。

Option Explicit
Const strPath = "D:\XX"
Sub replaceStarsToSheetName()
    
    Dim objFs As Object, objFld As Object, objFl As Object, Stream As Object, buf As String, i As Long
    
    Set objFs = CreateObject("Scripting.FileSystemObject")
    Set objFld = objFs.GetFolder(strPath)
    
    Set Stream = CreateObject("ADODB.Stream")
    
    ' 2シート目を対象にするために、iは2から始める
    i = 2
    For Each objFl In objFld.Files
        '
        ' MsgBox (objFl.Name) ' ファイル名の確認
        ' シートが存在する間、処理を実行
        If i <= Worksheets.Count Then
            Stream.Open
            Stream.Type = 2
            Stream.Charset = "utf-8"
            Stream.LoadFromFile objFl.Path
            buf = Stream.readText()
            buf = Replace(buf, "★★", Worksheets(i).Name)
            ' MsgBox (buf) ' 置換後の内容の確認
            Stream.Close
        Else
            MsgBox ("名称を取得するシートがありません。" &amp; vbCrLf &amp; "処理を中断しました。")
            Exit Sub
        End If
        i = i + 1
    ' 次のファイルに移動
    Next
    MsgBox ("すべてのファイルを処理しました。")

End Sub

参考になれば幸いです。

[参考URL]

id:taroemon

ご回答ありがとうございます。

2006/10/31 13:08:38
id:bonlife No.2

回答回数421ベストアンサー獲得回数752006/10/31 00:37:07

ポイント150pt

つまらないミスをしていたので修正しました。

ちょっと寝ぼけているようなので、こちらにもミスがありましたら申し訳ありません。

Option Explicit
Const strPath = "D:\XX"
Sub replaceStarsToSheetName()
    
    Dim objFs As Object, objFld As Object, objFl As Object, Stream As Object, buf As String, i As Long
    
    Set objFs = CreateObject("Scripting.FileSystemObject")
    Set objFld = objFs.GetFolder(strPath)
    
    Set Stream = CreateObject("ADODB.Stream")
    
    ' 2シート目以降のシート名を対象にするために、iは2から始める
    i = 2
    For Each objFl In objFld.Files
        '
        ' MsgBox (objFl.Name) ' ファイル名の確認
        ' シートが存在する間、処理を実行
        If i <= Worksheets.Count Then
        
            Stream.Open
            Stream.Type = 2
            Stream.Charset = "utf-8"
            Stream.LoadFromFile objFl.Path
            buf = Stream.readText()
            buf = Replace(buf, "★★", Worksheets(i).Name)
            ' MsgBox (buf) ' 置換内容の確認
            Stream.Close
            
            Stream.Open
            Stream.Type = 2
            Stream.Charset = "utf-8"
            Stream.writeText (buf)
            Stream.SaveToFile objFl.Path, 2
            Stream.Close
            
        Else
            MsgBox ("名称を取得するシートがありません。" &amp; vbCrLf &amp; "処理を中断しました。")
            Exit Sub
        End If
        i = i + 1
    ' 次のファイルに移動
    Next
    MsgBox ("すべてのファイルを処理しました。")
    
End Sub

ファイル名はいわゆる名前の順で取得されます。

[参考URL]

id:taroemon

ご回答ありがとうございました。

完璧に望んでいたものです。

2006/10/31 15:19:25

コメントはまだありません

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

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

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

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