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

エクセルマクロでCSVファイルを作成するマクロの記述について教えてください。
要望通りのご回答をくださったかたには300ポイント差し上げます。

【やりたいこと】
異なるファイル名のエクセルファイルがあるフォルダに複数保存されていて、そのすべてのファイルに含まれる「sheet1」シートのF1セル、G1セル、H1セル、I1セル、J1セルの値(但し、F1とJ1はブランクの場合もある)を、別エクセルファイル(マクロが登録されているファイル)の「sheet2」のA列,B列,C列,D列,E列にコピー&ペーストし、「sheet2」をCSVファイルでデスクトップに保存したい。

【留意事項】
(1)すべてのファイルにおいて、F1とJ1がブランクのケースもある。
(2)F1?J1はすべて文字列。
(3)最終的に完成するCSVファイルはテキストで開くと次のような形になる。
(G1は半角3文字、H1は半角7文字,I1は半角7文字固定)
,aaa,bbbbbbb,ccccccc,,
,ddd,eeeeeee,fffffff,,
,ggg,hhhhhhh,iiiiiii,,

いろいろ調べて作成しているものの、うまくいかずに戸惑っています。
よろしくお願いいたします。





●質問者: peppoli
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:AAA CSV DDD F1 G1
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

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

一応仕様に沿って作成しましたが、(3) の解釈が不明です。

元のデータが3(7)文字以上あって規定文字数に詰めるのか(その場合右詰?左詰?)

あるいは足りない場合があり、スペース等でパディングするのか。

今回は後者で作成しています。

'--- 収集するEXCEL ファイルのあるパス
Const DataFolder = "C:\Data"

Sub makeCSVData()
 Dim fso As Object
 Set fso = CreateObject("Scripting.FileSystemObject")

'--- 自ブックに Sheet2 があることが前提
 Dim r As Long
 Dim dstWS As Worksheet
 Set dstWS = ThisWorkbook.Worksheets("Sheet2")
 
'--- シートは Sheet1 でなく1シート目を指定:Sheet1 とする場合は
'--- Worksheets(1) を Worksheets("Sheet1") に変更。
 Dim cFile As Object
 For Each cFile In fso.getFolder(DataFolder).Files
 If LCase(fso.GetExtensionName(cFile.Path)) = "xls" Then
 r = r + 1
 With Workbooks.Open(cFile.Path)
 dstWS.Cells(r, "A") = .Worksheets(1).Range("F1")
 dstWS.Cells(r, "B") = Right(" " & .Worksheets(1).Range("G1"), 3)
 dstWS.Cells(r, "C") = Right(" " & .Worksheets(1).Range("H1"), 7)
 dstWS.Cells(r, "D") = Right(" " & .Worksheets(1).Range("I1"), 7)
 dstWS.Cells(r, "E") = .Worksheets(1).Range("J1")
 .Close
 End With
 End If
 Next
 
'--- とりあえずファイル名は 日付_時間.csv
 Dim Path As String
 dstWS.Copy
 Path = CreateObject("Wscript.Shell").SpecialFolders("Desktop") & "\" & Format(Date, "YYYYMMDD") & "_" & Format(Time, "HHMMSS") & ".csv"
 ActiveWorkbook.SaveAs Filename:=Path, FileFormat:=xlCSV
 ActiveWorkbook.Close
End Sub

不明な点や、仕様の解釈の違いがある場合コメントに手対応いたしますので、有効にお願いします。

◎質問者からの返答

ご回答いただき、ありがとうございます。

(3)について説明が悪く、大変失礼いたしました。

G1,H1,I1はユーザーが入力するセルであり、「桁数指定で入力せよ」と指示しても無視して入力するケースが発生するため、マクロで桁数を合わせる処理を入れようとしました。文字は右詰めで足りない部分をゼロ埋めしたいと思っています。


2 ● GreenStar
●50ポイント

お望みのマクロは下記を参照されるとよろしいでしょう。

(ほぼコピペで終わります。)

http://makotowatana.ld.infoseek.co.jp/vba_file2.html


具体的に作ろうかと思ったのですが、不明点がいろいろあります。

(1)CSVのようでCSVではない。

スタートとエンドをカンマにするというのは範囲内だと思いますが、

相手先に固定長で取り込ませたい場合は文字列をダブルクォートで囲まなければなりませんし、

Excelのcsv出力を用いる場合は、先頭の半角スペースは残らなかったりするので、

お望みのものは固定長テキスト形式で作成し、拡張子だけをcsvにするという事になります。

お手軽な方法としては「A列,B列,C列,D列,E列にコピー&ペースト」ではなく

「A列,B列,C列,D列,E列をコピー&出力用に1つにまとめたものをA列にペースト」という形にして、

固定長テキストとして出力するのが楽でしょう。

(2)あるフォルダに保存されているbook全てが対象?それとも一部?

マクロを記述してあるbookも「あるフォルダ」内にある場合は、自身を開こうとしないようにする条件分岐が入ります。

(3)どうしてもデスクトップ?

デスクトップフォルダの位置はOSやユーザー環境によって変わる場合があり、プログラム難易度があがります。

◎質問者からの返答

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

わかりづらい説明で大変失礼いたしました。

(1)承知しました。固定長テキストで出力できるか試してみます。

(2)保存されているすべてのbookが対象です。マクロは「あるフォルダ内」には存在していません。

(3)どうしてもデスクトップでなくてもよいです。デスクトップを指定したほうが楽なのでは?と勝手に思い込んでいたので、そのようにお願いしただけです。逆に難易度があがるとは知りませんでした。ありがとうございます。


3 ● p332
●50ポイント

エクセルのブック、シートは「CSV形式で保存する」ということができるのでこれを使えば大丈夫だと思います。

下記にコードを示します。

参照設定で

・Microsoft Scripting Runtime

・Windows Script Host Object Model

の2つを参照設定(メニューの「データ」から「参照設定」)しておかないと動きませんが、参照設定しておくと便利です。

データコピー先は、Sheet2の末端にコピーし、実行後の状態を保持します。

Sub main()
 
 Dim FSO As Scripting.FileSystemObject
 Dim F As File
 Dim WSH As WshShell

' Dim FSO As Object
' Dim F As Object
' Dim WSH As Object
 
 Dim WB As Workbook
 Dim ShtDst As Worksheet
 Dim RngDst As Range
 
 Set FSO = CreateObject("Scripting.FileSystemObject")
 
 '各フォルダ名、ファイル名設定
 rootFldrPath = ThisWorkbook.Path
 SrcFldrName = "data"
 SrcFldrPath = rootFldrPath & "\" & SrcFldrName
 
 Set WSH = CreateObject("Wscript.Shell")
 dstFldrPath = WSH.SpecialFolders("Desktop")
 dstFilePath = dstFldrPath & "\" & "data" & Format(Now, "yyyymmdd_hhmmss") & ".csv"
 
 'データコピー先取得
 Set ShtDst = ThisWorkbook.Sheets("Sheet2")
 With ShtDst.Cells.SpecialCells(xlCellTypeLastCell)
 If .Row = 1 And .Column = 1 Then
 lastRow = 0
 Else
 lastRow = ShtDst.Cells.SpecialCells(xlCellTypeLastCell).Row
 End If
 End With
 
 '指定したフォルダ内の全ファイル(拡張子が「.xls」か「.xlsx」のもの)からデータ取得
 For Each F In FSO.GetFolder(SrcFldrPath).Files
 If LCase(F.Name) Like "*.xls" Or LCase(F.Name) Like "*.xlsx" Then
 lastRow = lastRow + 1
 Set WB = Workbooks.Open(SrcFldrPath & "\" & F.Name)
 ShtDst.Cells(lastRow, 1).Resize(1, 5).Value = WB.Sheets("Sheet1").Cells(1, 6).Resize(1, 5).Value
 WB.Close False
 End If
 Next
 
 '「Sheet2」を新しいブックにコピー
 ShtDst.Copy
 Set WBtmp = ActiveWorkbook
 
 'CSVで保存して閉じる
 WBtmp.SaveAs dstFilePath, xlCSV
 WBtmp.Close False
 
End Sub


4 ● SALINGER
●50ポイント

概ね既に出ている回答でよろしいと思います。


ただ、一点気になったところがあって、

>(1)すべてのファイルにおいて、F1とJ1がブランクのケースもある。

全てのファイルのF1かJ1がブランクの場合、ExcelをCSVに直接保存すると、

最初と最後のコンマが付かないケースが出てくるので、テキストストリームから保存するようにしました。

(例ではデータが5つなのでコンマが一つ多いようですが、それも考慮しました)


1行目のファイルの有るフォルダのパスを変更して実行してみてください。

Sub Macro()
 Const FoldPath As String = "C:\Documents and Settings\hogehoge\デスクトップ\test"
 Dim FSO As Object
 Dim myFile As Object
 Dim ext As String
 Dim r As Long
 Dim TS As Object
 Dim SavePath As String
 Dim WSH As Object
 Dim str As String
 Dim i As Integer
 Dim wb As Workbook
 
 Set FSO = CreateObject("Scripting.FileSystemObject")
 Set WSH = CreateObject("Wscript.Shell")
 SavePath = WSH.SpecialFolders("Desktop") & "\result.csv"
 
 Set TS = FSO.CreateTextFile(Filename:=SavePath, Overwrite:=True)
 
 With ThisWorkbook.Worksheets("Sheet2")
 For Each myFile In FSO.GetFolder(FoldPath).Files
 ext = FSO.GetExtensionName(myFile)
 If LCase(ext) = "xls" Or LCase(ext) = "xlsx" Then
 r = r + 1
 Set wb = Workbooks.Open(myFile.Path)
 wb.Worksheets("Sheet1").Range("F1:J1").Copy .Cells(r, 1)
 wb.Close
 str = ""
 For i = 1 To 5
 str = str & .Cells(r, i) & ","
 Next i
 TS.WriteLine str
 End If
 Next
 End With
 
 TS.Close
 Set TS = Nothing
 Set FSO = Nothing
 Set WSH = Nothing
End Sub
関連質問


●質問をもっと探す●



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