ここから本文です

こんなことが出来るのでしょうか? 現在、手動で Excel .xlsxをデスクトップにc...

nor********さん

2019/5/412:21:41

こんなことが出来るのでしょうか?

現在、手動で
Excel .xlsxをデスクトップにcsv(コンマ区切り)で
名前をつけて保存。その後、拡張子を.txtに変更しています。

上記の作業を
Excelのマクロ.xlsmを使って
最終的にデスクトップに保存できますでしょうか?
その時、名前はcsvでの段階でセルA1.txtとしたいです。

但し、A1に /(スラッシュ)が入っている場合があるので
その時は / を外して名前を付けたいです。

宜しくお願い致します。

A1&quot,デスクトップ,セルA1.txt,bk.SaveAs dt,CreateObject,csv&quot,Desktop&quot

閲覧数:
64
回答数:
4
お礼:
25枚

違反報告

ベストアンサーに選ばれた回答

tok********さん

2019/5/412:55:00

Sub createCSVTXT()
Dim wsh, c
Dim n As Long, r As Long
Dim f As String
Set wsh = CreateObject("WScript.Shell")
f = wsh.SpecialFolders("Desktop") & "\" & Replace(Range("A1"), "/", "") & ".txt"
n = FreeFile
r = Cells(Rows.Count, 1).End(xlUp).Row
Open f For Output As #n
For Each c In Range("A1:A" & r)
Print #n, Cells(c.Row, 1) & "," & Cells(c.Row, 2) & "," & Cells(c.Row, 3) & "," & Cells(c.Row, 4)
Next c
Close #n
Set wsh = Nothing
End Sub

とかかな?

  • 質問者

    nor********さん

    2019/5/414:12:28

    回答有難う御座います。
    思い通りの結果が得られました。
    問題ありません。

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

質問した人からのコメント

2019/5/4 14:21:03

迅速な対応、且つ稚拙な文章力にも関わらず
回答いただき有難う御座いました。
活用させて頂きます。

ベストアンサー以外の回答

1〜3件/3件中

並び替え:回答日時の
新しい順
|古い順

Prometheusさん

2019/5/413:41:15

「VBScript」による回答ですので、「Windows限定」です。

このプログラムは、プログラムファイルに、「~.xlsx」ファイルをドラッグ&ドロップ(1つでも複数でも可)するだけです。

アクティブシートを「デスクトップ」に「Range("A1").csv」保存し、「csv」を「txt」に変換します。

以下のプログラムを、メモ帳かテキストエディタに貼り付け、「~.vbs」という名前で保存します。

「~」の部分は、何でもかまいませんが、「.vbs」の部分は、必ず、半角です。

できたプログラムファイル(「~.vbs」ファイル)に、拡張子が「xlsx」のエクセルブックをドラッグ&ドロップ(1つでも複数でも可)するだけです。

最後に「Finished!」と表示しますので、「OK」を押して、終了してください。

Option Explicit
Dim bk, ex, dt, f, i, n, sh, so, wa, ws
Set so = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
dt = ws.SpecialFolders("Desktop")
Set ex = CreateObject("Excel.Application")
ex.Application.DisplayAlerts = False
ex.Visible = False
Set wa = WScript.Arguments
For i = 0 to wa.Count - 1
If LCase(so.GetExtensionName(wa(i))) = "xlsx" Then
Set bk = ex.Workbooks.Open(wa(i))
Set sh = bk.ActiveSheet
n = Replace(sh.Range("A1").Value, "/", "")
n = Replace(n, "/", "")
bk.SaveAs dt & "\" & n & ".csv", 6
bk.Close
Set sh = Nothing
Set bk = Nothing
Set f = so.GetFile(dt & "\" & n & ".csv")
f.Name = n & ".txt"
End If
Next
ex.Quit
Set ex = Nothing
Set wa = Nothing
Set ws = Nothing
Set so = Nothing
MsgBox("Finished!")

ざっくりとした説明。

Set so = CreateObject("Scripting.FileSystemObject")

「Windows」のファイルやフォルダ、テキストファイルを扱う機能を読み込んでいます。

Set ws = CreateObject("WScript.Shell")

デスクトップを調べるのに必要。

dt = ws.SpecialFolders("Desktop")

「デスクトップ」フォルダを「dt」に入れています。

Set ex = CreateObject("Excel.Application")
ex.Application.DisplayAlerts = False
ex.Visible = False

エクセルを扱えるようにして、「上書きしますか?」などと聞いてこないように、また、エクセルを表示しません。

Set wa = WScript.Arguments

ドラッグ&ドロップを待っています。

For i = 0 to wa.Count - 1

ドラッグ&ドロップされたファイルを1つずつすべて処理。

If LCase(so.GetExtensionName(wa(i))) = "xlsx" Then

拡張子が「xlsx」なら、

Set bk = ex.Workbooks.Open(wa(i))

開いています。

Set sh = bk.ActiveSheet

アクティブシートを「sh」にセット。

n = Replace(sh.Range("A1").Value, "/", "")
n = Replace(n, "/", "")

セル「A1」の全角の「/」と半角の「/」を削除して、「n」に入れています。

bk.SaveAs dt & "\" & n & ".csv", 6

「デスクトップ」に「Range("A1").csv」で保存しています。

bk.Close
Set sh = Nothing
Set bk = Nothing

ブックを閉じています。

Set f = so.GetFile(dt & "\" & n & ".csv")
f.Name = n & ".txt"

「~.csv」を「~.txt」に変換しています。

End If
Next

を、ドラッグ&ドロップしたすべてのファイルで繰り返しています。

ex.Quit
Set ex = Nothing
Set wa = Nothing
Set ws = Nothing
Set so = Nothing
MsgBox("Finished!")

あとは、エクセルそのものと各種設定を終了して、「Finished!」と表示しています。

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

だるまさん

2019/5/413:41:57

>但し、A1に /(スラッシュ)が入っている場合があるので
その時は / を外して名前を付けたいです

ファイル名に使えないのは半角の/だけですので、全角の/は
そのままにしました。


Sub Sample()
    Dim Fpath As String
    Dim Fname As String
    
    Fpath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\"
    Fname = Range("A1").Value & ".txt"
    Fname = Replace(Fname, "/", "")
    
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Fpath & Fname, xlCSV
    Application.DisplayAlerts = True
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

プロフィール画像

カテゴリマスター

hot********さん

2019/5/413:43:17

対象シートはSheet1の場合です。
デスクトップのExcel.xlsxのSheet1をデスクトップにカンマ区切りで保存します。
ファイル名はSheet1のA1の値+".txt"です。
A1に"/"があったら削除します。

Sub sample()
Dim wsh As Object
Dim desktop As String
Dim wb As Workbook
Dim file As String
'
Set wsh = CreateObject("WScript.Shell") 'shellオブジェクト
desktop = wsh.SpecialFolders("Desktop") & "\" 'デスクトップのパス+"\"
Set wb = Workbooks.Open(desktop & "Excel.xlsx") 'デスクトップの"Excel.xlsx"を開く
wb.Sheets("Sheet1").Select 'Sheet1(対象シート)を選択
file = Replace(Range("A1").Value, "/", "") 'A1の値で"/"があったら削除(ファイル名)
wb.SaveAs desktop & file, FileFormat:=xlCSV 'CSVで保存
wb.Close False '保存したので閉じる
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる