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

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


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



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



●質問者: ヘンリ
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:Excel txt VBA いただきます エクセル
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● Mook
●300ポイント ベストアンサー

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

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

Mookさん

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

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

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

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



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

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

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

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

上記の、

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

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

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


感謝します!


2 ● うぃんど
●330ポイント

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

windofjulyさん

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

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

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

私が書かなかった、

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

ありがとうございます。

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

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



この度は感謝します。

関連質問


●質問をもっと探す●



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