[[20091119112315]]　『同一フォルダー内にあるcsvファイルを別ファイルａx（shinv230）　ページの最後に飛ぶ

『同一フォルダー内にあるcsvファイルを別ファイルにxls形式で一括保存』（shinv230）

 Excel 2003
 同一フォルダー内にあるcsvファイルを１つずつ開いて別フォルダーにxls形式で保存していますが
 ファイルが約２００個となると時間がかかり苦労しています。
 フォルダー内のcsvファイルを一括して別フォルダーにxls形式で保存する方法は無いでしょうか？
 よろしくお願いします。

 dir関数でフォルダ内のCSVファイルを一つずつ開いて、
 同名（または、別名の）のエクセルファイルに直して保存
 DIRで検索すれば、ヒットすると思います。
　（SHIOJII

SHIOJIIさんアドバイスありがとうございます。 DIRで検索しCSVファイルをエクセルファイルに直して元のフォルダーに保存することはできました。しかし，変換後のエクセルファイルを別フォルダーに保存する方法が分かりません。再度，アドバイスをお願いします。(shinv230)

現在のコードはどうなっているのでしょうか。
ファイル名指定のところでフォルダも指定すればできませんか。
（たるむ）

現在のコードは，以下になっています。(INAさんのサンプルを流用させいただきました)

 保存先のフォルダーは，毎月変更となりますので一定ではありません。

Sub xls変換()

 Dim myObj As Object
 Dim myDir As String
 Dim myFileName As String
 Dim myFileList As String
 Dim myFileCount As Long
 Dim wb As Workbook

 'フォルダ選択ダイアログの表示
    Set myObj = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "フォルダを選択してください", 0)
    If myObj Is Nothing Then Exit Sub

    myDir = myObj.Items.Item.Path
    If Right(myDir, 1) <> "\" Then myDir = myDir & "\"

 'フォルダ内のExcelファイルを確認
    myFileName = Dir(myDir & "*.xls")

    Do While myFileName <> ""
        If myFileName <> ThisWorkbook.Name Then
            myFileList = myFileList & Chr(13) & myFileName
            myFileCount = myFileCount + 1
        End If

        myFileName = Dir()
    Loop

    If myFileCount = 0 Then
       MsgBox "ファイルは見つかりませんでした。マクロを終了します。", 48
       Exit Sub
    ElseIf vbNo = MsgBox(myFileCount & " 個の .xls ファイルが見つかりました。マクロを実行しますか？" _
                                       & Chr(13) & myFileList, 4, "ファイル確認") Then
       MsgBox "キャンセルしました。"
       Exit Sub
    End If

 'CSV処理
    myFileName = Dir(myDir & "*.xls")

    Do While myFileName <> ""
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False

        If myFileName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(myDir & myFileName)
                wb.SaveAs Filename:=myDir & Left(myFileName, Len(myFileName) - 3) & "csv", _
                FileFormat:=xlCSV
                wb.Close
        End If

        myFileName = Dir()
    Loop

  Application.DisplayAlerts = True
  Application.ScreenUpdating = True

  MsgBox "完了しました。"

 End Sub

 変更箇所は以下の部分ですか？
　
　　　　If myFileName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(myDir & myFileName)
                wb.SaveAs Filename:=myDir & Left(myFileName, Len(myFileName) - 3) & "csv", _
                FileFormat:=xlCSV
                wb.Close
        End If

 (shinv230)

 はい、そうです。
 開くファイルのフォルダを選択しているようですから、
 同様に保存先のフォルダも選択できるようにすればよいですね。
（たるむ）

 そのコードは
 エクセルファイルをCSVにしていると思いますが。。。
 御質問は
 ＞csvファイルを別ファイルにxls形式で一括保存
 でしたよね？

 御質問内容が違っていた？
 それとも、
 ＞DIRで検索しCSVファイルをエクセルファイルに直して元のフォルダーに保存することはできました。
 と言う事なので、実際は載せておられるのと違うコードを使って居られる？

 (HANA)

 HANAさんご指摘ありがとうございます。
 質問内容は，csvファイルを別フォルダにxls形式で一括保存です。また，コードについてはご指摘どおり間違っています。
 参考にしたコードがエクセルファイルからCSVファイルに変換するものでしたので２通り作成したため，
 掲載するときに間違ってしまいました。正しいコードは，以下になります。

 Sub CSV変換()

 Dim myObj As Object
 Dim myDir As String
 Dim myFileName As String
 Dim myFileList As String
 Dim myFileCount As Long
 Dim wb As Workbook

 'フォルダ選択ダイアログの表示
    Set myObj = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "フォルダを選択してください", 0)
    If myObj Is Nothing Then Exit Sub

    myDir = myObj.Items.Item.Path
    If Right(myDir, 1) <> "\" Then myDir = myDir & "\"

 'フォルダ内のCSVファイルを確認
    myFileName = Dir(myDir & "*.csv")

    Do While myFileName <> ""
        If myFileName <> ThisWorkbook.Name Then
            myFileList = myFileList & Chr(13) & myFileName
            myFileCount = myFileCount + 1
        End If

        myFileName = Dir()
    Loop

    If myFileCount = 0 Then
       MsgBox "ファイルは見つかりませんでした。マクロを終了します。", 48
       Exit Sub
    ElseIf vbNo = MsgBox(myFileCount & " 個の .csv ファイルが見つかりました。マクロを実行しますか？" _
                                       & Chr(13) & myFileList, 4, "ファイル確認") Then
       MsgBox "キャンセルしました。"
       Exit Sub
    End If

 'Excel処理
    myFileName = Dir(myDir & "*.csv")

    Do While myFileName <> ""
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False

        If myFileName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(myDir & myFileName)
                wb.SaveAs Filename:=myDir & Left(myFileName, Len(myFileName) - 3) & "xls", _
                FileFormat:=xlExcel3
                wb.Close
        End If

        myFileName = Dir()
    Loop

  Application.DisplayAlerts = True
  Application.ScreenUpdating = True

  MsgBox "完了しました。"

 End Sub

 現在の状況は，マクロを実行すると元フォルダにCSVファイルとエクセルファイルの両方が保存されます。
 別フォルダへの保存方法については，まだ完成していません。(shinv230)

 ＞'フォルダ選択ダイアログの表示
 で、フォルダを選択すると　その後
 ＞If Right(myDir, 1) <> "\" Then myDir = myDir & "\"
 の処理まで進むと、[myDir]という変数に
 選択したフォルダのパスができていることは
 つかめていますか？

 たとえば、Cドライブ直下の新しいフォルダを選んだ場合
 [myDir] に C:\新しいフォルダ\ が完成しているので
 [myFileName]に データ1.csv が入っていた時に

 ＞Workbooks.Open(myDir & myFileName)

 myDir & myFileName → "C:\新しいフォルダ\" & "データ1.csv"
 → "C:\新しいフォルダ\データ1.csv"
 になるので、目的のファイルが開けます。

 保存するときは

 ＞Filename:=myDir & Left(myFileName, Len(myFileName) - 3) & "xls"

 [myFileName]に データ1.csv が入っていた場合
 Left(myFileName, Len(myFileName) - 3) で、「データ1.」が得られるので

 myDir & Left(myFileName, Len(myFileName) - 3) & "xls" → "C:\新しいフォルダ\" & "データ1." & "xls"
 → "C:\新しいフォルダ\データ1.xls"
 として（の場所に）保存されます。

 ですから、
 ＞マクロを実行しますか？
 で実行することにしたら
 ＞'フォルダ選択ダイアログの表示
 で、保存するフォルダを選びます。

 [myDir]に入っている情報はまだ必要なので（CSVファイルを開くときに使います）
 新しい変数を用意して、そこにフォルダまでのパスを作成し
 保存するFilenameの所で　使うようにします。

 shinv230さんが書いておられる
 ＞変更箇所は以下の部分ですか？
 の部分の変更と共に（というか、変更するために？）
 たるむさんが書いておられる
 ＞同様に保存先のフォルダも選択できるようにすれば
 が追加で必要です。

 それに伴い、新しい変数の宣言も必要になってきます。
 Dim myDir As String
 これは、ファイルが保存してあるフォルダの文字列が入っているので
 新しく、ファイルを保存するフォルダの文字列を入れる変数を追加してください。

 (HANA)

HANAさんご指導いただいてから時間がだいぶ過ぎましたが無事完成しました。

 以下に完成後のコードを掲載させて頂きます。

 Sub CSV変換()
 Dim myObjA As Object
 Dim myDirA As String
 Dim myFileNameA As String
 Dim myFileListA As String
 Dim myFileCountA As Long
 Dim wb As Workbook

 Dim myObjB As Object
 Dim myDirB As String

 '変換元フォルダ選択ダイアログの表示
    Set myObjA = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "変換元のフォルダを選択して　「ＯＫ」　をクリックしてください", 0)
    If myObjA Is Nothing Then Exit Sub

    myDirA = myObjA.Items.Item.Path
    If Right(myDirA, 1) <> "\" Then myDirA = myDirA & "\"

 'フォルダ内のＣＳＶファイルを確認
    myFileNameA = Dir(myDirA & "*.csv")

    Do While myFileNameA <> ""
        If myFileNameA <> ThisWorkbook.Name Then
            myFileListA = myFileListA & Chr(13) & myFileNameA
            myFileCountA = myFileCountA + 1
        End If

        myFileNameA = Dir()
    Loop

    If myFileCountA = 0 Then
       MsgBox "ファイルは見つかりませんでした。変換を終了します。", 48
       Exit Sub
    ElseIf vbNo = MsgBox(myFileCountA & " 個の .csv ファイルが見つかりました。変換を実行しますか？" _
                                       & Chr(13) & myFileListA, 4, "ファイル確認") Then
       MsgBox "キャンセルしました。"
       Exit Sub
    End If

 '保存先フォルダ選択ダイアログの表示
    Set myObjB = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "変換後の保存先フォルダを選択して　「ＯＫ」　をクリックしてください", 0)
    If myObjB Is Nothing Then Exit Sub

    myDirB = myObjB.Items.Item.Path
    If Right(myDirB, 1) <> "\" Then myDirB = myDirB & "\"

 'Excel処理
    myFileNameA = Dir(myDirA & "*.csv")

    Do While myFileNameA <> ""
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False

        If myFileNameA <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(myDirA & myFileNameA)
                wb.SaveAs Filename:=myDirB & Left(myFileNameA, Len(myFileNameA) - 3) & "xls", _
                FileFormat:=xlExcel3
                wb.Close
        End If

        myFileNameA = Dir()
    Loop

  Application.DisplayAlerts = True
  Application.ScreenUpdating = True

  MsgBox "完了しました。"

 End Sub

 今後ともご指導願います。（shinv230)

コメント返信：

[ 一覧(最新更新順) ]

[[20091119112315]] 『同一フォルダー内にあるcsvファイルを別ファイルａx（shinv230） ページの最後に飛ぶ

[[20091119112315]]　『同一フォルダー内にあるcsvファイルを別ファイルａx（shinv230）　ページの最後に飛ぶ