Excel(エクセル)のマクロ(VBA)を作ってください。

そのまま使えるマクロをご提供くださった方にお気持ちですが、600ポイント以上差し上げたいと思います。

列のパターン→ 右側へ続きます
  ↓
保存先フォルダ 列の先頭に1つあります
ファイル名1  データの先頭にあります
文字列データ
文字列データ
 空白行
ファイル名2
文字列データ
  ・
  ・
文字列データ
 空白行
終了


文字列データは増減します。
列が20くらい右側にあり増えていきます。
列の終わりは空白です。

1.アクティブセルが最初の列の保存先フォルダにあるかを確認して
2.保存先フォルダ先を確認して
3.データをファイル名をつけてテキストファイルで保存して
4.次のデータを・・・と繰り返して
5.「終了」になったら次の列の保存先フォルダに移り「2.」から始める
6.次の列が空白ならば終了する。
ということをしたいのです。

それと確認は最初に一回だけ(1.の処理)で、あとは一気に処理をする方法も知りたいです。

offsetやEnd(xlDown)を使って作ろうとしたのですが、能力不足で間に合いません。
どうか皆様のお力をかしてください。

回答の条件
  • 1人5回まで
  • 登録:2009/10/23 14:12:36
  • 終了:2009/10/23 18:23:12

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3430ベストアンサー獲得回数9692009/10/23 15:20:36

ポイント800pt

標準モジュールにコピペして、最初の列の保存先フォルダを選択して実行してください。

セルの保存先フォルダがフルパスなのかフォルダ名なのか、

ファイル名に拡張子がついているかなどで若干の修正が必要かもしれませんが、

ご指摘いただければ修正いたします。


Sub Macro()
    Dim r As Long
    Dim c As Long
    Dim FSO
    Dim TS
    Dim filName As String
    Dim foldPath As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.FolderExists(Selection.Value) Then
        r = Selection.Row
        c = Selection.Column
        While Cells(r, c).Value <> ""
            If FSO.FolderExists(Cells(r, c).Value) Then
                foldPath = Cells(r, c).Value
                While Cells(r + 1, c).Value <> "終了"
                    r = r + 1
                    filName = Cells(r, c).Value
                    'フォルダのパスが\で終わるときは"\"を削除
                    'ファイル名に拡張子がつかなければ拡張子をつける
                    Set TS = FSO.OpenTextFile(foldPath & "\" & filName, 2, True)
                    r = r + 1
                    While Cells(r, c).Value <> ""
                        TS.WriteLine (Cells(r, c).Value)
                        r = r + 1
                    Wend
                    TS.Close
                Wend
            Else
                MsgBox Cells(r, c).Value & vbNewLine & "は存在しません"
            End If
            c = c + 1
            r = Selection.Row
        Wend
    Else
        MsgBox "保存先フォルダのセルを選択してください"
    End If
    
    Set FSO = Nothing
End Sub
id:han001

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

最初の

MsgBox "保存先フォルダのセルを選択してください"

のところでセルポインタがうごきません。

最初の一列はファイル保存ができました。

二回目に試すと

パスがみつかりませんとでます。

今、矢継ぎ早に3件の回答があり焦っています。

2009/10/23 16:05:52

その他の回答(2件)

id:SALINGER No.1

SALINGER回答回数3430ベストアンサー獲得回数9692009/10/23 15:20:36ここでベストアンサー

ポイント800pt

標準モジュールにコピペして、最初の列の保存先フォルダを選択して実行してください。

セルの保存先フォルダがフルパスなのかフォルダ名なのか、

ファイル名に拡張子がついているかなどで若干の修正が必要かもしれませんが、

ご指摘いただければ修正いたします。


Sub Macro()
    Dim r As Long
    Dim c As Long
    Dim FSO
    Dim TS
    Dim filName As String
    Dim foldPath As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.FolderExists(Selection.Value) Then
        r = Selection.Row
        c = Selection.Column
        While Cells(r, c).Value <> ""
            If FSO.FolderExists(Cells(r, c).Value) Then
                foldPath = Cells(r, c).Value
                While Cells(r + 1, c).Value <> "終了"
                    r = r + 1
                    filName = Cells(r, c).Value
                    'フォルダのパスが\で終わるときは"\"を削除
                    'ファイル名に拡張子がつかなければ拡張子をつける
                    Set TS = FSO.OpenTextFile(foldPath & "\" & filName, 2, True)
                    r = r + 1
                    While Cells(r, c).Value <> ""
                        TS.WriteLine (Cells(r, c).Value)
                        r = r + 1
                    Wend
                    TS.Close
                Wend
            Else
                MsgBox Cells(r, c).Value & vbNewLine & "は存在しません"
            End If
            c = c + 1
            r = Selection.Row
        Wend
    Else
        MsgBox "保存先フォルダのセルを選択してください"
    End If
    
    Set FSO = Nothing
End Sub
id:han001

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

最初の

MsgBox "保存先フォルダのセルを選択してください"

のところでセルポインタがうごきません。

最初の一列はファイル保存ができました。

二回目に試すと

パスがみつかりませんとでます。

今、矢継ぎ早に3件の回答があり焦っています。

2009/10/23 16:05:52
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912009/10/23 15:27:12

ポイント800pt

フォルダのチェックは毎列していますが、フォルダがある限りはエラーにならない(メッセージが出ない)ので

問題ないかと思います。

'----------------------------------------
Sub makeFiles()
'----------------------------------------
    Dim baseCell As Range
    Set baseCell = Cells(1, ActiveCell.Column)
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim r As Long
    Dim c As Long
    Dim lastRow As Long
'// 列のループ
    For c = baseCell.Column To Columns.Count
        If Cells(1, c).Value = "" Then Exit Sub
        lastRow = Cells(Rows.Count, c).End(xlUp).Row
        If checkFolder(Cells(1, c).Value) = False Then
            Exit Sub
        End If
        r = 1
'// 行のループ
        Do While r <= lastRow
            r = r + 1
            With fso.CreateTextFile(Cells(1, c).Value & "\" & Cells(r, c).Value)
                r = r + 1
                Do While Cells(r, c).Value <> ""
                    .WriteLine Cells(r, c).Value
                    r = r + 1
                Loop
                .Close
            End With
        Loop
    Next
End Sub

'----------------------------------------
Function checkFolder(folderPath)
'----------------------------------------
    If Dir(folderPath, vbDirectory) = "" Then
        checkFolder = False
        MsgBox "【" & folderPath & "】がありません。"
    Else
        checkFolder = True
    End If
End Function
id:han001

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

動きました。

終了のファイルができましたが無問題です。

前の人のコメントにも書きましたが、

最初に2列目とか3列目のフォルダパスにセルポインタがあった場合

そのまま動いてしまうのでやはり最初に確認をしたいのですが。

2009/10/23 16:33:49
id:frkw2004 No.3

ふるるP回答回数192ベストアンサー獲得回数212009/10/23 15:33:00

ポイント100pt

'アクティブセルは使っていません。

'標準モジュールに以下のプログラムをペーストし、

'ALT+F8(マクロの実行)から使えるようになります。

Sub OutpuText()

Dim sFile As String 'ファイル名

Dim sFolder As String ' フォルダパス

Dim iRow As Long '行番号

Dim iCol As Long '列番号

Dim iFNo As String 'ファイル番号

Dim wTxt As String

sFolder = Range("A1").Value

iRow = 2

iRow = iRow + 1

If "" & Cells(iRow, 1).Value = "" Then

MsgBox "ファイル名がありません"

Exit Sub

End If

iCol = 1

Do

iRow = 1

sFolder = Cells(iRow, iCol)

If sFolder = "" Then

'先頭行にフォルダパスが無いのでおしまい

Exit Do

End If

If Dir(sFolder, vbDirectory) = "" Then

MsgBox "保存先フォルダが見つかりませんでした"

Exit Sub

End If

iRow = 2

Do

If "" & Cells(iRow, iCol).Value = "" Then

MsgBox "行:" & iRow & ",列:" & iCol & " ファイル名が設定されてません。"

Exit Sub

End If

sFile = sFolder & "\" & Cells(iRow, iCol).Value

iFNo = FreeFile

Open sFile For Output As #iFNo

iRow = iRow + 1

Do

wTxt = Cells(iRow, iCol).Value

If wTxt = "" Then

Exit Do

Else

Print #iFNo, wTxt

End If

iRow = iRow + 1

Loop

iRow = iRow + 1

Close #iFNo

If Cells(iRow, iCol) = "終了" Then

'列のおしまい

Exit Do

End If

Loop

iCol = iCol + 1 '次の列へ

Loop

End Sub

id:han001

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

試しましたが、うごきませんでした。(私が悪いかも?)

エラーもでませんでした。

2009/10/23 16:54:37
  • id:SALINGER
    何点が質問です。
    保存先フォルダはあらかじめあるわけではなく、フォルダも作成するのでしょうか?
    保存先フォルダはフォルダ名だけですか?
    ファイル名に拡張子はついていますか?
  • id:han001
    最初にお断りします。すごく焦っていました。すみませんでした。
    今、データを見たら最後の終了が入っていませんでした。
    試したらうまく動きました。ありがとうございます。
    ただ最初に2列目とか3列目のフォルダパスにセルポインタがあった場合
    そのまま動いてしまうのでやはり最初に確認をしたいのですが。
  • id:SALINGER
    なるほど、データが左詰であるとは限らないのであえて実装しなかった部分です。
    9行目の
    If FSO.FolderExists(Selection.Value) Then

    If FSO.FolderExists(Selection.Value) And Selection.Column = 1 Then
    に変更してください。
  • id:han001
    今試してたのですが、
    [フォルダパス]は存在しませんと列の数だけでてしまいます。
  • id:Mook
    一箇所仕様ミスです。
    各列が「終了」で終わるためには

     Do While r <= lastRow
       r = r + 1
       With fso.CreateTextFile(Cells(1, c).Value & "\" & Cells(r, c).Value)

     Do While r <= lastRow
       r = r + 1
       If Cells(r, c).Value = "終了" Then Exit Do
       With fso.CreateTextFile(Cells(1, c).Value & "\" & Cells(r, c).Value)

    としてください。
    終了でなく、最後のデータまで処理するなら現状のままでかまいません。


    処理の開始は2行目、3行目のセルが選択されていても、その列の1行目から
    処理するようにしています。

    どこか1行目に実際に存在しないフォルダが指定されていた場合、
    その列で終了していますが、その仕様で問題あるようでしたら、
    コメントください。
  • id:han001
    最初の質問で文字制限にかかりうまく説明しきれていませんでした。
    実際の最初のフォルダパスはAE4にあります(右へ動く可能性あり)。左は空白列ですがすぐ上にもデータがあります。
    すぐ上に空白行をつくることはできますが。
    セルポインタ(アクティブセル?)がどこにあるかを確認してそこから処理をはじめたかったのですが。
  • id:SALINGER
    仕様に不明な部分があるので最初のコメントに答えていただけませんか?
  • id:SALINGER
    一応データの左上(アクティブセル)がどこでもいいように作ってるけど。
    1列目ってA列を意味するわけじゃないのね。
    さて、データの最初の列であることをどうやって調べるか。
    データの途中に空白が無いのなら、左が空白でいいかな。
  • id:Mook
    失礼
    SALINGER さんのはその仕様になっていましたね。

    後はお任せします。
  • id:SALINGER
    >後はお任せします。
    いえ、Mookさんの回答は無問題みたいなんで。
    質問者様が作りたいものに近いんじゃないでしょうか。

    たぶん私にしろMookさんにしろ、han001さんが作りたいものの仕様がちゃんと伝われば簡単だと思うけど。
  • id:han001
    Mook様 SALINGER様 frkw2004様

    私の説明のいたらなさでご迷惑をおかけしたことを深くお詫びいたします。
    なにか私の頭が混乱しているようで、申し訳ございませんでした。
    私は単純にアクティブセルの位置を取得してそこを基準に処理できないかと
    考えていたのです。それで最初の基準セルの位置の確認をしたかったんです。
    そのあとoffset(1)やEnd(xlDown)でマクロをつくろうとしたのですができなくて
    質問しました。
    皆様のコードをみるととても恥ずかしいです。
    ここで一旦この質問を打ち切りたいと思います。
    また、機会があればぜひご回答をお寄せくださるようお願いいたします。
    皆様方のご協力を感謝しております。
  • id:Mook
    あらら、目的は達成できたのでしょうか。

    >私の説明のいたらなさでご迷惑をおかけしたことを深くお詫びいたします。
    ぜんぜん迷惑していませんよ。

    二人からコメントが乱立すると混乱すると思いましたので、SALINGER さんにお任せしようと思ったのですが、
    実現できていない点があるのであれば納得するまで説明されてはどうでしょうか。

    SALINGER さんもそうだと思いますが、私も問題解決しないことのほうが気になってしまいますので、質問終了後でも
    かまいませんので、実現できていない点があったらコメントください。

    処理の開始はアクティブセルだと思いますが、隣の列の処理開始行はどこになりますか?
    アクティブセルの隣ですか?

    あと、最初のSALINGERさんのコメントも確認されるとよいかと思います。
    実際にフォルダが無い場合作成することも可能ですが、その処理は不要ですか?
  • id:SALINGER
    後もう少しだと思うのですが、お役に立てなくて申し訳ありません。
    質問文の字数制限もあり、言葉で伝えるのはなかなか難しいですね。
    けっこう他の方はExcelのスクリーンショットを撮って画像を用意したりして工夫してるようです。
     
    未解決にも関わらず大量のポイントを貰ってしまったので、
    ブログの方にフォルダが無い場合作成する方向でコードを作ってみました。
    http://d.hatena.ne.jp/SALINGER/20091023
     
    はてなの回し者ではありませんが、これに懲りずにまた質問してみてください。
    そのときは微力ながらお手伝いさせていただきます。

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

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

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

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