エクセルマクロで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,,

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



回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2010/03/31 00:54:43
  • 終了:2010/04/04 23:11:01

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912010/03/31 01:33:34

ポイント100pt

一応仕様に沿って作成しましたが、(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

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

id:peppoli

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

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

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

2010/04/01 23:26:07

その他の回答(3件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912010/03/31 01:33:34ここでベストアンサー

ポイント100pt

一応仕様に沿って作成しましたが、(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

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

id:peppoli

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

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

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

2010/04/01 23:26:07
id:GreenStar No.2

GreenStar回答回数192ベストアンサー獲得回数462010/03/31 01:37:05

ポイント50pt

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

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

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やユーザー環境によって変わる場合があり、プログラム難易度があがります。

id:peppoli

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

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

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

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

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

2010/04/01 23:31:23
id:p332 No.3

p332回答回数36ベストアンサー獲得回数32010/03/31 04:23:12

ポイント50pt

エクセルのブック、シートは「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

id:SALINGER No.4

SALINGER回答回数3454ベストアンサー獲得回数9692010/03/31 17:24:03

ポイント50pt

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


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

>(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
  • id:Mook
    問題は解決したでしょうか。

    0パディングする部分に関しては、
     Right(" " & .Worksheets(1).Range("H1"), 7)

     Right("0000000" & .Worksheets(1).Range("H1"), 7)
    のようにすればいいですが、もしも7文字以上入力された場合はそのままにしたい場合、
    下記のように条件判定をいれる必要があります。

    If Len( CStr(.Worksheets(1).Range("H1"))) <7 Then
       dstWS.Cells(r, "C") = Right("0000000" & .Worksheets(1).Range("H1"), 7)
    Else
       dstWS.Cells(r, "C") = .Worksheets(1).Range("H1")
    End If

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません