| |
お世話になります。
（Excel2000使用）
フォルダ選択ダイアログを表示させた後で、
そのフォルダ内のXLSファイルを【複数指定】して、CSV変換するマクロを作成したい
のですが、
「そのフォルダ内のXLSファイルを複数指定する」方法がよく分からないので、
どなたかアドバイスを頂きたく宜しくお願いいたします。
出来たら、保存先フォルダ選択ダイアログの表示も付けたいです。
以下が、フォルダ選択ダイアログを表示させた後で、
そのフォルダ内のXLSファイルを全て表示し、それらをCSV変換させて、
保存先フォルダに格納するVBAになります。
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 & "\"
'フォルダ内のXLSファイルを確認
myFileNameA = Dir(myDirA & "*.xls")
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 "XLSファイルは見つかりませんでした。CSV変換を終了します。", 48
Exit Sub
ElseIf vbNo = MsgBox(myFileCountA & " 個の .xls ファイルが見つかりました。
変換を実行しますか？" _
& Chr(13) & myFileListA, 4, "ファイル
確認") Then
MsgBox "キャンセルしました。"
Exit Sub
End If
'保存先フォルダ選択ダイアログの表示
Set myObjB = CreateObject("Shell.Application"). _
BrowseForFolder(0, "CSV変換後の保存先フォルダを選択して 「ＯＫ」 をク
リックしてください", 0)
If myObjB Is Nothing Then Exit Sub
myDirB = myObjB.Items.Item.Path
If Right(myDirB, 1) <> "\" Then myDirB = myDirB & "\"
'CSV処理
myFileNameA = Dir(myDirA & "*.xls")
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(myFileNam
eA) - 3) & "csv", _
FileFormat:=xlCSV
wb.Close
End If
myFileNameA = Dir()
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "完了しました。"
End Sub
|
|