人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

列のパターン→ 右側へ続きます

保存先フォルダ 列の先頭に1つあります
ファイル名1 データの先頭にあります
文字列データ
文字列データ
空白行
ファイル名2
文字列データ


文字列データ
空白行
終了


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

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

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

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

●質問者: han001
●カテゴリ:コンピュータ インターネット
✍キーワード:Excel VBA をかし アクティブ エクセル
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●800ポイント ベストアンサー

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

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

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

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


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
◎質問者からの返答

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

最初の

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

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

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

二回目に試すと

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

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


2 ● Mook
●800ポイント

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

問題ないかと思います。

'----------------------------------------
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
◎質問者からの返答

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

動きました。

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

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

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

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


3 ● ふるるP
●100ポイント

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

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

'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

◎質問者からの返答

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

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ