エクセルマクロにて下記のようにセルを配列した文字列があった場合、

 |A列|B列
---------
1|A |ABC
2|B |DEF
3|C |GHI
b列のセルの内容をテキストファイルで保存し、ファイル名をA列の文字列で保存したいのですがどのようなマクロを組めばいいのでしょうか?
出来ればそのまま使える形で答えていただけると助かります。
最終的には
A.txt→テキスト内容:ABC
B.txt→テキスト内容:DEF
C.txt→テキスト内容:GHI
と保存できればOKです。数量が15000行あってすべてファイルに直すには時間がかかるのでお力を貸してください。

回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2010/04/18 06:33:11
  • 終了:2010/04/23 17:16:12

ベストアンサー

id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692010/04/18 11:40:55

ポイント70pt

マクロで作る上で何点か押さえておくポイントとして、

  • 同名のファイルだったり、ファイル名に出来ない文字列が含まれている場合など、

何らかの理由でファイルが作成出来ない場合の処理。

  • B列に改行が含まれていた場合の処理。

下記のコードをコピペして実行すると最初に保存場所を聞いてきて、

指定した場所に上書きをせずに保存します。


Sub 行ごとに保存()
    Dim FSO As Object
    Dim lastRow As Long
    Dim i As Long
    Dim TS As Object
    Dim SucCount As Integer
    Dim ErrCount As Integer
    Dim str As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")

    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "保存する場所を選択してください"
        If .Show = True Then
            For i = 1 To lastRow
                On Error Resume Next
                Set TS = FSO.CreateTextFile(.SelectedItems(1) & "\" & Cells(i, 1).Value & ".txt", False)
                
                '意味の無い文字列に一旦エスケープ
                str = Replace(Cells(i, 2).Value, vbCrLf, ";@:][/")
                str = Replace(str, vbLf, vbCrLf)
                str = Replace(str, ";@:][/", vbCrLf)
                
                TS.Write (str)
                If Err.Number > 0 Then
                    ErrCount = ErrCount + 1
                Else
                    SucCount = SucCount + 1
                End If
                TS.Close
                Set TS = Nothing
                On Error GoTo 0
            Next i
        End If
    End With
    
    MsgBox "成功: " & SucCount & vbNewLine & "失敗: " & ErrCount
    
    Set FSO = Nothing
End Sub

その他の回答(2件)

id:jccrh1 No.1

jccrh1回答回数111ベストアンサー獲得回数192010/04/18 06:49:08

ポイント50pt
Sub ファイル出力()
  Const 出力フォルダ = "D:\"
  Set 範囲 = Range(Range("B1"), Range("A65536").End(xlUp))
  For I = 1 To 範囲.Rows.Count
    Open 出力フォルダ & 範囲(I, 1) & ".txt" For Output As #1
    Print #1, 範囲(I, 2)
    Close #1
  Next I
End Sub
id:rsc96074 No.2

rsc回答回数4388ベストアンサー獲得回数4022010/04/18 08:36:42

ポイント30pt

 こちらは参考になるでしょうか。

Sub myMacro()
    Dim n, i As Long
    Dim fName As String
    Dim sheetobj As Worksheet
    Set sheetobj = ThisWorkbook.Worksheets(1)
    
    n = FreeFile
    With sheetobj
        For i = 1 To LastRow(sheetobj, 1)
            fName = .Cells(i, 1) + ".txt"
            Open fName For Output As #n
            Print #n, .Cells(i, 2)
            Close #n
        Next i
    End With
End Sub

Function LastRow(sheetobj As Worksheet, C)
    LastRow = sheetobj.Cells(sheetobj.Rows.Count, C).End(xlUp).Row
End Function

※参考URL

●Office TANAKA - Excel VBA講座:ファイルの操作[テキストファイルを ...

http://officetanaka.net/excel/vba/file/file08.htm

●VBA応用(テキストデータの書き出し)

http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_040.html

id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692010/04/18 11:40:55ここでベストアンサー

ポイント70pt

マクロで作る上で何点か押さえておくポイントとして、

  • 同名のファイルだったり、ファイル名に出来ない文字列が含まれている場合など、

何らかの理由でファイルが作成出来ない場合の処理。

  • B列に改行が含まれていた場合の処理。

下記のコードをコピペして実行すると最初に保存場所を聞いてきて、

指定した場所に上書きをせずに保存します。


Sub 行ごとに保存()
    Dim FSO As Object
    Dim lastRow As Long
    Dim i As Long
    Dim TS As Object
    Dim SucCount As Integer
    Dim ErrCount As Integer
    Dim str As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")

    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "保存する場所を選択してください"
        If .Show = True Then
            For i = 1 To lastRow
                On Error Resume Next
                Set TS = FSO.CreateTextFile(.SelectedItems(1) & "\" & Cells(i, 1).Value & ".txt", False)
                
                '意味の無い文字列に一旦エスケープ
                str = Replace(Cells(i, 2).Value, vbCrLf, ";@:][/")
                str = Replace(str, vbLf, vbCrLf)
                str = Replace(str, ";@:][/", vbCrLf)
                
                TS.Write (str)
                If Err.Number > 0 Then
                    ErrCount = ErrCount + 1
                Else
                    SucCount = SucCount + 1
                End If
                TS.Close
                Set TS = Nothing
                On Error GoTo 0
            Next i
        End If
    End With
    
    MsgBox "成功: " & SucCount & vbNewLine & "失敗: " & ErrCount
    
    Set FSO = Nothing
End Sub

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

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

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

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

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