次の動作をするExcel(エクセル)2007のVBA(マクロ)コードを教えてほしいです。



1行目(のセル)に「置換」というデータが含まれている列のみを対象に、
2行目のデータをテキストファイル名(.txt)にして、3行目以降のデータをテキストファイルの中身にするコードです。
(エクセル表のデータを、条件にしたがって、テキストファイルとして出力するVBAコードです。)



※長くなってしまったので、具体的な「続き」を、このページ下部の「この質問・回答へコメントを書く」欄に書かせていただきます。
よろしくおねがいします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/04/23 15:32:31
  • 終了:2011/04/23 20:06:57

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912011/04/23 17:08:00

ポイント300pt

前回の逆の処理だと解釈しましたが、よろしいでしょうか。

Option Explicit

'// コマンドボタン処理
'//-----------------------------------
Private Sub CommandButton1_Click()
    Const updateFolder = "最新の置換データ(予備データ)"

    If MsgBox("最新の置換データ(予備データ)を作成しますか?", vbYesNo, "更新確認") <> vbYes Then
        Exit Sub
    End If

    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    
'// フォルダの再作成
    Dim folderPath As String
    folderPath = ThisWorkbook.Path & "\" & updateFolder
    If fso.FolderExists(folderPath) = True Then
        fso.DeleteFolder folderPath, True
    End If
    fso.createFolder folderPath

    Dim colRange As Range
    Dim filePath As String
    Dim r As Range
    For Each colRange In Rows(1).Cells
        If InStr(colRange.Value, "置換") > 0 Then
'// ファイルの作成
            filePath = folderPath & "\" & colRange.Offset(1, 0).Value & ".txt"
            With fso.CreateTextFile(filePath)
                For Each r In colRange.Offset(2, 0).Resize(Cells(Rows.Count, colRange.Column).End(xlUp).Row - 2)
                    .WriteLine r.Value
                Next
                .Close
            End With
        End If
    Next
    MsgBox "最新の置換データ作成が完了しました!"
End Sub
id:egaosaiko

Mookさん

こんなに速いご回答、ほんとうにありがたいです。

さっそく色んなパターンで試させていただきました。

3行目以降にデータがない場合は使わない予定なので、そこはエラーになっても問題ありません。

なので、今回も完璧とも言えるコードだと思いました。



>コマンドボタン実行(CommandButton1_Click)で、

>メッセージボックスが「最新の置換データ(予備データ)を作成しますか?」と表示するようにします。

>(※そもそもエクセルの1行目に、「置換」というデータが含まれている列が存在しないときは、

>メッセージボックスで「作成できる置換データがありません!」と表示したいです。)

上記の、

>(※そもそもエクセルの1行目に、「置換」というデータが含まれている列が存在しないときは、

>メッセージボックスで「作成できる置換データがありません!」と表示したいです。)

この部分が抜けていたぐらいでしょうか、欲を言えば。


感謝します!

2011/04/23 19:47:23

その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912011/04/23 17:08:00ここでベストアンサー

ポイント300pt

前回の逆の処理だと解釈しましたが、よろしいでしょうか。

Option Explicit

'// コマンドボタン処理
'//-----------------------------------
Private Sub CommandButton1_Click()
    Const updateFolder = "最新の置換データ(予備データ)"

    If MsgBox("最新の置換データ(予備データ)を作成しますか?", vbYesNo, "更新確認") <> vbYes Then
        Exit Sub
    End If

    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    
'// フォルダの再作成
    Dim folderPath As String
    folderPath = ThisWorkbook.Path & "\" & updateFolder
    If fso.FolderExists(folderPath) = True Then
        fso.DeleteFolder folderPath, True
    End If
    fso.createFolder folderPath

    Dim colRange As Range
    Dim filePath As String
    Dim r As Range
    For Each colRange In Rows(1).Cells
        If InStr(colRange.Value, "置換") > 0 Then
'// ファイルの作成
            filePath = folderPath & "\" & colRange.Offset(1, 0).Value & ".txt"
            With fso.CreateTextFile(filePath)
                For Each r In colRange.Offset(2, 0).Resize(Cells(Rows.Count, colRange.Column).End(xlUp).Row - 2)
                    .WriteLine r.Value
                Next
                .Close
            End With
        End If
    Next
    MsgBox "最新の置換データ作成が完了しました!"
End Sub
id:egaosaiko

Mookさん

こんなに速いご回答、ほんとうにありがたいです。

さっそく色んなパターンで試させていただきました。

3行目以降にデータがない場合は使わない予定なので、そこはエラーになっても問題ありません。

なので、今回も完璧とも言えるコードだと思いました。



>コマンドボタン実行(CommandButton1_Click)で、

>メッセージボックスが「最新の置換データ(予備データ)を作成しますか?」と表示するようにします。

>(※そもそもエクセルの1行目に、「置換」というデータが含まれている列が存在しないときは、

>メッセージボックスで「作成できる置換データがありません!」と表示したいです。)

上記の、

>(※そもそもエクセルの1行目に、「置換」というデータが含まれている列が存在しないときは、

>メッセージボックスで「作成できる置換データがありません!」と表示したいです。)

この部分が抜けていたぐらいでしょうか、欲を言えば。


感謝します!

2011/04/23 19:47:23
id:windofjuly No.2

うぃんど回答回数2625ベストアンサー獲得回数11492011/04/23 17:57:45

ポイント330pt

id:Mookさんの回答があるのでもういいかなと思いつつも違う部分があるので投稿させていただきました

Private Sub CommandButton1_Click()
    Dim FSO As Object
    Dim searchText As String
    Dim textFile As Object, saveFolderName As String
    Dim sName As String
    Dim startCell As Range, goalCell As Range, findCell As Range, targetCell As Range
    Dim startColumn As Long, startRow As Long, lastRow As Long
    Dim i As Long
    
    '********** 設定 **********
    searchText = "置換": '検索文字列
    saveFolderName = ActiveWorkbook.Path & "\最新の置換データ(予備データ)": '保存先フォルダ
    sName = "Sheet1": 'シート名
    Set startCell = Range("X1"): '検索開始位置
    Set goalCell = Range("Z1"): '検索終了位置

    With ThisWorkbook.Worksheets(sName)
        '********** 確認 **********
        '「置換」を含むセルの存在チェックとスタート位置確定
        Set findCell = .Rows(startCell.Row).Find(searchText, , xlValues, xlPart, xlByColumns, xlNext, False)
        If (findCell Is Nothing) Then
            If MsgBox("作成できる置換データがありません!", vbOKOnly, "エラー") Then Exit Sub
        End If
        '置換確認
        If MsgBox("最新の置換データ(予備データ)を作成しますか?", vbOKCancel, "確認") <> vbOK Then Exit Sub
        '********** 実行 **********
        'フォルダ削除
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FolderExists(saveFolderName) Then FSO.DeleteFolder saveFolderName, True: 'フォルダが存在すれば強制削除
        FSO.CreateFolder saveFolderName
        For Each targetCell In Range(findCell, goalCell)
            If InStr(targetCell.Value, searchText) > 0 Then
                startRow = targetCell.Row + 2
                lastRow = Cells(Rows.Count, targetCell.Column).End(xlUp).Row:  '最終行を求める
                '3行目以降にデータがある場合にのみテキストファイルを作成する
                If lastRow >= startRow Then
                    startColumn = targetCell.Column
                    Set textFile = FSO.OpenTextFile(saveFolderName & "\" & targetCell.Offset(1, 0).Value & ".txt", 2, True): 'ファイルを書き込みモードで開く
                    For i = startRow To lastRow
                        textFile.writeline Cells(i, startColumn)
                    Next i
                    Set textFile = Nothing
                End If
            End If
        Next targetCell
        Set FSO = Nothing
        MsgBox "最新の置換データ作成が完了しました!", vbOKOnly, "終了"
    End With
End Sub

3行目以降にデータがなくてもファイルを作成する場合は下記の2行を削除

                '3行目以降にデータがある場合にのみテキストファイルを作成する
                If lastRow >= startRow Then  ←ここ削除
                    startColumn = targetCell.Column
                    Set textFile = FSO.OpenTextFile(saveFolderName & "\" & targetCell.Offset(1, 0).Value & ".txt", 2, True): 'ファイルを書き込みモードで開く
                    For i = startRow To lastRow
                        textFile.writeline Cells(i, startColumn)
                    Next i
                    Set textFile = Nothing
                End If  ←ここ削除
id:egaosaiko

windofjulyさん

お答えしていただき、ありがとうございます。

さっそく試させていただきました。

エラーなく動いてくれるコード、とても助かります。

私が書かなかった、

テキストファイル名だけで、中身が空の場合のテキストファイル作成についても対応していただき、

ありがとうございます。

明らかに私の質問の仕方が悪かったのですが、

どの列にも対応したコードだったらまさに完璧だったと思います。



この度は感謝します。

2011/04/23 20:05:11
  • id:egaosaiko

    (↓続きです)
    ※上から下へとそのまま順に読み進めていただきたいです。



    具体的には例えば


    X1:
    X2:(動物1)
    X3:いぬ
    X4:ねこ
    X5:ねずみ
    X6:うさぎ
    X7:へび


    Y1:置換1
    Y2:(動物2)
    Y3:犬
    Y4:猫
    Y5:鼠
    Y6:兎
    Y7:蛇


    Z1:置換2
    Z2:(かわいい)
    Z3:かわいい
    Z4:可愛い
    Z5:カワイイ
    Z6:とてもかわいい
    Z7:とても可愛い


    ↑のように、1つのシート(Sheet1)においてデータがあるとき、




    コマンドボタン実行(CommandButton1_Click)で、
    メッセージボックスが「最新の置換データ(予備データ)を作成しますか?」と表示するようにします。
    (※そもそもエクセルの1行目に、「置換」というデータが含まれている列が存在しないときは、
    メッセージボックスで「作成できる置換データがありません!」と表示したいです。)


    ●ここで「いいえ」を選択すると
    ↓↓↓
    何もしません。


    ●ここで「はい」を選択すると、
    ↓↓↓
    まず、このエクセルと同じディレクトリ(階層)に
    「最新の置換データ(予備データ)」という名前のフォルダを作成します。
    (もちろん、この時点ではまだ中身は空です。)

    -----------------------------------------------------------------------------
    ※【補足】
    もし、すでに「最新の置換データ(予備データ)」フォルダが存在する場合は、
    まずその(すでに存在している)「最新の置換データ(予備データ)」フォルダのみを(フォルダごと)削除します。
    (フォルダ名が「最新の置換データ(予備データ)」と「完全に一致するフォルダだけを削除」します。
    なので、フォルダ名が「最新の置換データ」の場合は削除しません。)

    その後に、新しく「最新の置換データ(予備データ)」フォルダ(空)を作成します。
    -----------------------------------------------------------------------------




    エクセル表(Sheet1)の1行目に「置換」というデータが含まれている(部分的に一致している)列の、
    2行目のデータを「テキストファイル名」とし、
    3行目以降のデータを「ファイルの中身」とするテキストファイル(.txt)を作成します。
    (※「最新の置換データ(予備データ)」フォルダの中に、テキストファイルが作成されるようにします。)


    上記の例でいうと、



    X1:
    X2:(動物1)
    X3:いぬ
    X4:ねこ
    X5:ねずみ
    X6:うさぎ
    X7:へび


    Y1:置換1
    Y2:(動物2)
    Y3:犬
    Y4:猫
    Y5:鼠
    Y6:兎
    Y7:蛇


    Z1:置換2
    Z2:(かわいい)
    Z3:かわいい
    Z4:可愛い
    Z5:カワイイ
    Z6:とてもかわいい
    Z7:とても可愛い

    ↓↓↓


    「最新の置換データ(予備データ)」フォルダの中に、
    以下のテキストファイル(.txt)が作成されることになります。


    (動物2).txt
    ----------------





    | ←(※ここまで改行するという意味です。)
    ----------------


    (かわいい).txt
    ----------------
    かわいい
    可愛い
    カワイイ
    とてもかわいい
    とても可愛い
    | ←(※ここまで改行するという意味です。)
    ----------------


    ---------------------------------------------------------------------------------------------
    ※【補足】
    テキストファイル作成が完了したときは、メッセージボックスが「最新の置換データ作成が完了しました!」と
    表示するようにしたいです。

    複数のテキストファイル作成が完了した場合は、すべてのテキストファイル作成が完了した後、
    「1回だけ」メッセージボックスが「最新の置換データ作成が完了しました!」と表示するようにしたいです。
    ---------------------------------------------------------------------------------------------





    ここまでの条件を満たすエクセルVBA(マクロ)のコードを知りたいです。
    分かる方(できる方)いましたら、どうかよろしくお願いします。。

    もしかすると、伝わっていない部分など多々あるかもしれません。
    分かりにくい点・疑問な点は、このコメント欄に書いていただけるととても助かります。


  • id:egaosaiko
    Mookさん windofjulyさん

    ご回答していただき、ありがとうございました。


    今回はいろいろ考えた結果、
    シート名が変わっても、どの列を対象にするにしても
    コードを極力手直しすることなく使えるMookさんのコードをベストアンサーとさせていただきました。

    しかし、

    windofjulyさんは、テキストファイル作成時極力エラーにならないように考慮してくださったので、
    Mookさんよりpt(回答ポイント)を多く差し上げることにいたしました。


    どうかよろしくお願いいたします。
  • id:windofjuly
    うぃんど 2011/04/23 20:37:23
    >シート名が変わっても
    シート名固定ではなく可変であれば、下記の対応となります
    sName = Activesheet.Name: 'シート名
     
    >どの列を対象にするにしても
    選択されているセルを対象にする場合は下記の対応となります
    Set startCell = Selection: '検索開始位置
    Set goalCell = Selection: '検索終了位置
     
    その他にも色々な使い方が出来るようにしてありますので、お時間あればどうぞ
  • id:Mook
    ①の
    >メッセージボックスで「作成できる置換データがありません!」と表示したいです。)
    が抜けていましたねw。
    最初の方の Const .... の行の次に下記を入れてください。

      If Rows(1).Find("置換", lookat:=xlPart) Is Nothing Then
        MsgBox "作成できる置換データがありません!"
        Exit Sub
      End If

    空対応は、windofjuly さんのが参考になると思いますが、対応が必要でしたらコメント下さい。
  • id:egaosaiko
    windofjulyさんへ

    変更コードを教えていただきありがとうございます。

    >sName = Activesheet.Name:
    これはいいですね!
    さっそく取り入れさせていただきました。


    >どの列を対象にするにしても
    これは、できればセルを選択するという手間を省いて、
    1行目に「置換」というデータを含むすべての列が対象になってくれれば、と思っています。

    windofjulyさんがご回答していただいたコードですと、
    どうやらA列が対象外になるようです。
    (1行目に「置換」というデータがあっても、テキストファイルが作成されません。)

    もし、A列も処理対象にするコードがわかりましたら、
    どうかよろしくおねがいします。
  • id:egaosaiko
    Mookさんへ

    すばやい対応ありがとうございます。
    「作成できる置換データがありません!」と表示してくれるようになりました。
    助かります。


    >空対応は、windofjuly さんのが参考になると思いますが、対応が必要でしたらコメント下さい。
    テキストファイルの空(データ)対応コードについても、ぜひ教えてほしいです。

    人によってコードの書き方が違うので、
    いろんなパターンを知りたいですので。

    どうかよろしくおねがいします。
  • id:Mook
    データがのときに作成したくない場合は
        If InStr(colRange.Value, "置換") > 0 Then

        If InStr(colRange.Value, "置換") > 0 And Cells(Rows.Count, colRange.Column).End(xlUp).Row > 2 Then
    に変更してください。

    おまけ:
    最後の End Sub の直前に下記を置いてみるとちょっと便利かも。
    Shell "C:\Windows\Explorer.exe " & folderPath, vbNormalFocus
  • id:egaosaiko
    Mookさんへ

    対応ありがとうございます。

    >Shell "C:\Windows\Explorer.exe " & folderPath, vbNormalFocus
    これはかなり自然の流れで確認できるという意味で、とても便利だと思います。
    教えていただきありがとうございます。


    >If InStr(colRange.Value, "置換") > 0 And Cells(Rows.Count, colRange.Column).End(xlUp).Row > 2 Then
    このコードについてなんですが、
    3行目以降にデータがない場合(ファイル名はあるけど、テキストファイルの本文が無い状態)でも、
    (エラーになることなく)そのままテキストファイル作成するコードにすることは可能でしょうか。

    一応、本文(中身)が無くても、
    (ファイル名が存在するだけの)テキストファイルとして認識できる仕様にしておきたいのです。


    どうかよろしくおねがいいたします。
    お手数かけます。
  • id:windofjuly
    うぃんど 2011/04/23 22:05:06
    >セルを選択するという手間
    そういった使い方もできるという例です
    >A列対象外の意味がわかりません
    Selectionを使った場合は、選択されているセルの左上を基点とした一列だけが対象となります
     
    >1行目に「置換」というデータを含むすべての列が対象
    (例1)
    Set startCell = Range("A1"): '検索開始位置
    Set goalCell = Range("IV1"): '検索終了位置
    (IVはExcel2003までの互換モードでの上限。Excel2007からは列数が増えてますので適当に増やしてください)
     
    (例2)
    Set startCell = Range("A1"): '検索開始位置
    With ThisWorkbook.Worksheets(sName)
    Set goalCell = .Rows(startCell.Row).Find(searchText, , xlValues, xlPart, xlByColumns, xlPrevious, False): '検索終了位置
  • id:Mook
    ああ、データが無いときにエラーになりますね。
    他にもファイル名の重複の懸念もありますね。

    これらに対応するとこんな感じでしょうか。
      For Each colRange In Rows(1).Cells
        If InStr(colRange.Value, "置換") > 0 And Cells(2, colRange.Column).Value <> "" Then
    '// ファイルの作成
          filePath = folderPath & "\" & colRange.Offset(1, 0).Value & ".txt"
      '// ファイルの有無の確認
          If fso.FileExists(filePath) = True Then
            MsgBox colRange.Column & "列めは既に " & fso.GetFile(filePath).Name & " があるので、保存できません。"
          Else
            With fso.CreateTextFile(filePath)
      '// データの有無の確認
              If Cells(Rows.Count, colRange.Column).End(xlUp).Row > 2 Then
                For Each r In colRange.Offset(2, 0).Resize(Cells(Rows.Count, colRange.Column).End(xlUp).Row - 2)
                  .WriteLine r.Value
                Next
              End If
              .Close
            End With
          End If
        End If
      Next
  • id:egaosaiko
    windofjulyさんへ

    お返事ありがとうございます。

    >>セルを選択するという手間
    >そういった使い方もできるという例です
    申し訳ありません。「手間」という私の配慮のない書き方で、
    windofjulyさんがお気を悪くされていなければいいのですが。

    >>A列対象外の意味がわかりません
    >Selectionを使った場合は、選択されているセルの左上を基点とした一列だけが対象となります
    ここは私の言葉ではうまく伝えられませんでしたが、
    A列を処理の対象にしないことで「解決できる」と思います。
    (↑この文章も意味がわからないとは思いますが、そこはお気になさらないでください^^)


    (例1)、(例2)は今すぐには使わないと思いますが、
    参考にさせていただきます。


    windofjulyさん
    有用な情報ありがとうございます。
  • id:egaosaiko
    Mookさんへ

    考えうるエラーに対処した修正コード、本当にありがたいです!

    ここまで対応できるVBAになるとは思ってもいなかったので、
    かなりうれしいです。

    特に、
    >MsgBox colRange.Column & "列めは既に " & fso.GetFile(filePath).Name & " があるので、保存できません。"
    この配慮には驚きました。

    おかげで理想以上の動作をする珠玉のツールになったと思います。


    改めてありがとうございます。

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

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

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

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