CSVをxlsxにする作業の自動化

こんにちは。閲覧いただきありがとうございます。

csv形式のファイルをExcelで開く際に、テキストウィザードで全て文字列にして表示した後に、xlsx形式で保存する作業があるのですが、ファイルが100個くらいあるため、これを自動でやってくれるVBAはないでしょうか。

全て文字列とする理由は、「001」などが「1」として表示されないようにするためです。
※使用しているExcelのバージョンは2010と2016で、OSはWindows7とWindows10です。

ボタンをクリックしたら、ダイアログボックスが表示されてCSVのあるフォルダをユーザーが選択し、選択されたフォルダの中に入っているCSVが全てテキストウィザードで、文字列として読み込まれてxlsx形式で同じフォルダに保存されるのが理想ですが、なかなか希望通りのVBAが見つかりません。

もし、上記のような処理をしてくれるVBAをご存知でしたらご教授いただけますと幸いです。

ネットで下記のようなマクロを見つけたので試してみたのですが、このマクロで作られたxlsxファイルは「001」を「1」として表記されてしまいました。

**********************************************************
Option Explicit

Sub csv_excel()

Dim DirName As String, OpenFileName As String
Dim OpenBook As Workbook

Application.ScreenUpdating = False '画面更新非表示
Cells(2, 4).ClearContents

'ダイアログでフォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "保存フォルダを選択して下さい"
If .Show = False Then Exit Sub
DirName = .SelectedItems(1)
End With

'保存フォルダの作成
If Dir(DirName & "\Excel", vbDirectory) = "" Then
MkDir DirName & "\Excel"
End If

'csvアイル取得
OpenFileName = Dir(DirName & "\*.csv")

'ファイルをエクセルに変換
Do While OpenFileName <> ""
Set OpenBook = Workbooks.Open(Filename:=DirName & "\" & OpenFileName, ReadOnly:=True)
OpenBook.SaveAs Filename:=DirName & "\Excel" & "\" & Left(OpenFileName, Len(OpenFileName) - 3) & "xlsx", _
FileFormat:=xlWorkbookDefault
OpenBook.Close
OpenFileName = Dir()
Loop

ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Cells(2, 4) = DirName
Application.ScreenUpdating = True '画面更新表示

MsgBox "完了しました"
End Sub

ちなみにＣＳＶファイルの中身は、
このような感じにコンマとダブルクォーテーションで区切られています。

"aaa","001","bbb","002","お菓子","1-1-1",

No.3 ベストアンサー 回答者： WindFaller 回答日時： 2018/03/03 00:46

こんばんは。

作っている途中で、別に枝番などは不要だということと、"" に囲まれた文字列があるこに気が付きましたので、付け足しになってしまいましたが、とりあえず、このようなものはいかがでしようか。

'//標準モジュール
Sub CSV2XLSX()
　Dim FName, MyPath
　Dim Fn As String
　Dim i As Long, j As Long, k As Long
　Dim n As Variant, kt As Long, cnt As Long
　Dim BaseName As String
　Dim wb As Workbook
　Dim ext As String: ext = ".csv"
　Dim ext2 As String: ext2 = ".xlsx"
　ReDim myArray(2000)
　'CSV全てを､Excel形式にする
　With Application.FileDialog(msoFileDialogFolderPicker)
　　 .Title = "保存フォルダを選択して下さい"
　　 If .Show = False Then Exit Sub
　　 MyPath = .SelectedItems(1) & "\"
　End With
　FName = Dir(MyPath & "*" & ext, vbNormal)
　Do While FName <> ""
　　 If FName <> "." And FName <> ".." Then
　　　 If (GetAttr(MyPath & FName) And vbNormal) = vbNormal And LCase(Right(FName, 4)) = ext Then
　　　　　myArray(i) = FName
　　　　　i = i + 1
　　　　　If i > 2000 Then
　　　　　　 MsgBox "2000件を越えています。", vbExclamation
　　　　　　 Exit Do
　　　　　End If
　　　 End If
　　 End If
　　 FName = Dir
　Loop
　If i <= 0 Then MsgBox "CSVファィルはそこにはありません。", vbCritical: Exit Sub
　kt = Int(Log(i - 1) / Log(10)) + 1 '枝番の桁の用意　'別の意図で作られました。
　ReDim Preserve myArray(i - 1)
　j = 1
　Application.ScreenUpdating = False
　For Each n In myArray
　　 Set wb = Workbooks.Open(MyPath & n)
　　 DoEvents
　　 With wb.ActiveSheet
　　　.Cells.Replace """", "", xlPart
　　 End With
　　 k = InStrRev(n, ".")
　　 If k > 0 Then
　　　 BaseName = Mid(n, 1, k - 1)
　　 Else
　　　 BaseName = n
　　 End If
　　 FName = Dir(MyPath & BaseName & ext2, vbNormal)
　　 Do Until FName = ""
　　　 j = j + 1
　　　 BaseName = BaseName & Format(j, String(kt, "0"))
　　　 FName = Dir(MyPath & BaseName & ext2, vbNormal)
　　 Loop
　　 cnt = cnt + 1
　　 Application.StatusBar = cnt & "　" & n & " を処理中"
　　 wb.SaveAs MyPath & BaseName & ext2, xlWorkbookDefault
　　 wb.Close False
　　 Application.StatusBar = False
　　 Set wb = Nothing
　Next
　Application.ScreenUpdating = True
　MsgBox cnt & "件処理しました。", vbInformation
End Sub

この回答へのお礼

WindFaller 様

お忙しい中マクロを組んで下さりありがとうございます。
問題なく動作し、今までの作業がとても効率よくなり大変助かりました。

お礼日時：2018/03/05 12:48

No.2 回答者： GooUserラック 回答日時： 2018/03/01 16:39

それでしたら以下が参考になると思います。

http://www.moug.net/tech/exvba/0060086.html

No.1 回答者： GooUserラック 回答日時： 2018/03/01 16:21

列数は固定でしょうか？

固定ならば csvファイルの読み込みではなく textファイル読み込みで文字列指定した物をマクロ記録すればほぼそのまま使えると思います。固定出ないならば「Open」や「LineInput」等、使うようになると思います。

この回答へのお礼

GooUserラック 様
この度は返信ありがとうございます。
列数は固定ではなく、ファイルによって違いますので、LineInputを使ってちょっと手直してみます、ありがとうございます。

お礼日時：2018/03/01 16:31