お世話になります。


エクセルのマクロで

フォルダを新しく作って、そこにエクセルシート上の特定箇所をテキストファイルで生成したいと思っています。

具体的には、

Sheet1の
行1にフォルダ名
行2にテキスト名
行3~行6にデータ

フォルダを作ってテキストファイルを生成するといった感じです。
行は複数行あって、行1のフォルダ名が同じ場合は、テキストファイルを同じフォルダに格納するようにもしたいのです。

例えば、
Sheet1が
A1:くだもの
A2:リンゴ
A3~A6:テキストデータ
B1:やさい
B2:ダイコン
B3~B6:テキストデータ
C1:やさい
C2:ナス
C3~C6:テキストデータ

となっていた場合、

「くだもの」と「やさい」というフォルダを作って、
「くだもの」には、「リンゴ.txt」
「やさい」には、「ダイコン.txt」「ナス.txt」
を入れるといった感じです。

どうぞ、宜しくお願い致します。

回答の条件
  • URL必須
  • 1人5回まで
  • 登録:2008/01/31 07:35:26
  • 終了:2008/01/31 22:37:06

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692008/01/31 08:31:30

ポイント100pt

こんな感じでどうでしょうか

Sub Macro()
    Dim FSO
    Dim c As Long
    'ファイルを作る場所を指定
    Const myPath As String = "C:\Documents and Settings\hogehoge\デスクトップ\test1"
    
    c = 1
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    '同名フォルダが存在する場合のエラーを無視します
    On Error Resume Next
    
    While Cells(1, c).Value <> ""
        FSO.CreateFolder (myPath & "\" & Cells(1, c).Value)
    
        With FSO.GetFolder(myPath & "\" & Cells(1, c).Value).CreateTextFile(Cells(2, c).Value & ".txt")
            .WriteLine Cells(3, c).Value
            .WriteLine Cells(4, c).Value
            .WriteLine Cells(5, c).Value
        End With
        c = c + 1
    Wend
    On Error GoTo 0
    
    Set FSO = Nothing
End Sub

\を¥(半角)に置き換えてください。

http://q.hatena.ne.jp/

id:pinko_pinpin

SALINGER様

完璧ですっ!!

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

2008/01/31 22:32:53

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

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

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

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