▽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はユーザーが入力するセルであり、「桁数指定で入力せよ」と指示しても無視して入力するケースが発生するため、マクロで桁数を合わせる処理を入れようとしました。文字は右詰めで足りない部分をゼロ埋めしたいと思っています。
お望みのマクロは下記を参照されるとよろしいでしょう。
(ほぼコピペで終わります。)
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)どうしてもデスクトップでなくてもよいです。デスクトップを指定したほうが楽なのでは?と勝手に思い込んでいたので、そのようにお願いしただけです。逆に難易度があがるとは知りませんでした。ありがとうございます。
エクセルのブック、シートは「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
概ね既に出ている回答でよろしいと思います。
ただ、一点気になったところがあって、
>(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