OUTLOOK VBA 指定フォルダ内のメール添付ファイル2つをエクセルのシートにまとめるマクロ

Question

OUTLOOKのVBAがあることを知り、今の作業を自動化できないか調べています。
ネットで検索してマクロ作成を試しているのですが、うまく動作することができず、お力をお貸しいただけないでしょうか。EXCEL VBA初心者です。

■利用環境
OSバージョン：Windows10（64bit版）
Outlookバージョン：office365

■前提
 毎日、出荷データをメール受信しています。1日8～12回。
 メールには、CSVデータが2つ添付されています。(出荷AAA.csv　出荷BBB.csv)。固定。
 夕方に1日の受信した出荷データをエクセルにまとめてファイル名に日付をつけて保存しています。
ファイル名：出荷データ_20190930.excel
それぞれ、出荷AAAと出荷BBBシートそれぞれに、データをまとめている。

多い時には、12個のメールの添付ファイルを開いて、エクセルにコピペの繰り返し、名前を付けて保存をしており、作業の効率化を図れないか考えています。

■実現したいこと
(1)指定フォルダ内のすべてのメールの添付ファイル2つををエクセルのそれぞれのシートに書き出し、その日の日付入りの名前をつけて保存したい。
 指定フォルダにまとめたいメールをコピペしておき、マクロを実行すると、（1）を行ってほしい。
できれば、データが古いものから順に貼り付けていきたい。（指定フォルダ内の時間が古い順に）
 更にできれば、出荷AAA.csv　出荷BBB.csvは、データだけでタイトル行がないので、エクセルシートのそれぞれ1行名にタイトル行も設定したい。

調べたのですが、2つの添付ファイルをそれぞれまとめて保存することや、CSV形式ですぐにつまずきました。どうぞよろしくお願いいたします。

Qchan1962 · Accepted Answer

おおっと！！　確かに拡張子大文字にできるけど、、勉強になりました。
念のため、
If InStr(File_Name, ".csv") Then
部分を
If InStr(File_Name, ".csv") Or InStr(File_Name, ".CSV") Then
にておいた方が良いかと思います。
いずれにしても、良かったです。スキル不足から、長い時間を使いすみませんでした。

Qchan1962 · Answer

色々な検証有難うございます。VBAの知識付きますね。。。

If File_Name Like "*" & ".csv" Then

Like　演算に問題があるようなので、
取敢えず、その行をコメントにして下記にしてみてください。
             If InStr(File_Name, ".csv") Then
これで、
　　　　 ReDim Preserve strPath(1 To i)
　　　　 strPath(i) = Folder_Path & "\" & File_Name
　　　　 i = i + 1
は、実行されると思います。（csvファイルであれば）

よろしくお願いします。

Qchan1962 · Answer

私のテスト環境でエラーが出ないので苦戦しております。

検証を切り分けて行いたいと思います。
Outlook_csv_integration部分だけで、Outlookの設定フォルダにあるメールの添付ファイルを
デスクトップのTmpVBA_Workフォルダ内に連番を付けて保存する。のみを実行してみてください。
Outlook_csv_integration　プロシージャの

'     Call CSV_Inport(path1, flg)
'     If flg = False Then GoTo ErrExcel
'     For i = InboxFolder.Items.Count To 1 Step -1
'             Set MyExplorer = InboxFolder.Items(i)
'             MyExplorer.Move DoneFolder
'     Next i
'     fso.DeleteFolder path1
をコメントアウトして実行し、デスクトップにTmpVBA_Workフォルダが作られ、中に添付ファイルのCSVファイルが保存しているか確認してください。
ファイルの数などを確認して、問題がなければ、このプロシージャに問題がない事になり、コメント化した部分を元に戻してください。
＊コードのコメント化、非コメントにするのはVBEの上部タグをクリックすると容易です。（イメージ添付します）

もし、エラーなどが発生する場合は、
　　　　　　　　 If fldr = "xxxxx@xxxxxxx.com" Then '変更箇所（必須）
　　　　　　　　　　　　 Set InboxFolder = fldr.Folders("出荷報告")
　　　　　　　　　　　　 Set DoneFolder = fldr.Folders("処理済み出荷報告")
　　　　　　　　　　　　 Exit For
　　　　　　　　 End If
上記、アカウント名やフォルダ名を確認してください。
ちなみに、フォルダは、受信フォルダなどと同じ階層です。サブフォルダではありませんので合わせて確認してください。

Outlook_csv_integrationでエラーがない場合は、
次に、 CSV_Inport　プロシージャ以下を実行して確認します。

Sub CSV_Inport(Folder_Path As String, flg As Boolean)　をコメントにしてエンターキーで下の行に、
3行加えます。

Sub CSV_Inport()
Dim Folder_Path, i, flg
Folder_Path = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\" & "TmpVBA_Work"

OFF_ScreenUpdat
　　 On Error GoTo ErrorSheet
は引き続きコメントアウトしておいてください。エラーを出すため。

これで、実行してみてください。

For i = 1 To UBound(strPath)　ここで、デバッグエラーになるようであれば、
一旦終了して、Sub CSV_Inport()内で　F8キーでステップ実行してみてください。
F8キーを押下度に上から一行ずつ実行されていくと思いまうが、

If File_Name Like "*" & ".csv" Then　　’これは必ず実行される。
　　　　 ReDim Preserve strPath(1 To i)
　　　　 strPath(i) = Folder_Path & "\" & File_Name
　　　　 i = i + 1
　End If
この中のコードが実行されるか確認してください。
ここは、すべてのCSVファイルになっていますので、CSVがあれば必ず、ReDim Preserve strPath(1 To i)以下が
実行されると思います。

また、1行ずつ実行している時の　File_Name　にマウスポインタ―を当て、表示される
値が、設定した共通ファイルのキー（名前）が含まれているか確認してください。

OFF_ScreenUpdat をコメント化しているとシートを削除しますかと2回聞かれます。

もし、よろしければ、アカウント情報以外実際に設定するワードを掲示してください。
同じフォルダなどを作成し検証してみます。コード自体、アカウント設定以外触らなくてよいように直しますのでいかがですか？

必要情報
①メールフォルダ名（処理前用）
②メールフォルダ名（処理済み用）
③添付ファイルAの名前共通ワード
④添付ファイルBの名前共通ワード
⑤添付ファイルAの統合ファイル名
⑥添付ファイルBの統合ファイル名
⑦1行目に入る項目名　A列から順番に　、、、、幾つでもOK

以上

Qchan1962 · Answer

#15情報に対して
CSVを読むところでエラーが出るのですね。
一応、私のローカルでは、実行され期待通りになったので行けるかと思ったのですが、、

エラー９なので、ファイルがないか、シートがないか、などだと考えられます。
テストした時にエラーが発生しなかったので、変更されたCSVファイル名、読み込みシート名と思うのですが
検証しないと判りません。
ただ、OUTLOOKの処理、添付ファイルの抽出は、問題なく実行された事になります。
処理の最後にメールを別フォルダに移動しますが、先ず問題ないでしょう。

普段よく使っているExcel側の問題で、ややショックです。
色々やっている内に、すっかり慣れてしまったかもしれませんが、以下のような検証をお願いします。
手数をお掛けします。

先ず、シート名が上手くいっていない事を想定して、シンプルにAとBとかAAAとかにしてみてください。
もしくは、
Const ShNameA As String = "出荷まとめA" 'シート名A変更箇所
Const ShNameB As String = "出荷まとめB" 'シート名B変更箇所
の　出荷まとめB　をコピーしてシート名などにしてみてください。
シート名に意図せず作ってしまう可能性のある半角スペースなどにも気を付けてください。

また、CSVファイル名も再度確認をお願いします。　共通のファイル名ただし、AとBが判別できる文字を設定してください。
TmpVBA_Workフォルダ内のシート名をコピーして、Const CsvA As String = "AA"のAAにあたるところにペーストしてみてください。
ナンバーなど共通でない部分は、なくてOKです。

最後に、On Error GoTo ErrorSheet　の　頭に　’を入力してコメントにして無効にします。
これは、どこでエラーになっているかを確認するためです。デバッグでエラーがあれば、発生したところで止まります。

ファイル名などを掲示しても良いなら、
エラー検証の1つのやり方で、VBEで表示から、ローカルウィンドウを表示して、On Error GoTo ErrorSheetをコメントにして実行、エラーが出る。
ローカルウィンドウ内の変数を確認、特に　strPath()　ここには　+　文字があると思うので　+をクリックすると配列に読み込まれた
ファイル名がstrPath(1)　～～　strPath(2)　～～　のように表示されます。　それが、入っていない様であれば、CSVファイル名が
上手く抽出できなかったと言う事になります。（多分ここだと思うのですが、なぜなのか確認したいと思います）

もし可能なら、ローカルウィンドウで表示された内容、　+部分を展開したものを　コピペで掲示してください。
開示できない部分は、XXXなどでいかがでしょう。

以下は、関係ないと思いますが、
私のExcelは、2013　と　2016　（1909）クイック実行　です。
OS,Officeはアップデートの保留はせず。すぐ実施しています。

ここまで来たら、最後までしっかり責任持ちたいので。。

bonaron · Answer

横から失礼します。
OutLook VBA の例です。

動けばいいや、ということで目一杯手抜きしています。
OutLook の メールが保存されているフォルダを選択しておいて実行してください。

デスクトップに「出荷データ」というフォルダがあり、
その中に「Work」というフォルダがあることを前提としています。
「Work」に添付ファイルを一時保存し、「出荷データ」に Excel ファイルを保存します。

Option Explicit

' ここはご自分の環境に合わせて書き換える。
Const SAVE_FOLDER As String = "C:\Users\Watashi\Desktop\出荷データ"
Const SHEET_A　 As String = "出荷AAA"
Const SHEET_B　 As String = "出荷BBB"
Const ITEM_A　 As String = "項目A1,項目A2,項目A3,項目A4"
Const ITEM_B　 As String = "項目B1,項目B2,項目B3,項目B4"
'-------------------------------------------------
Sub 添付ファイルまとめ()
　　Dim objItems As Items
　　Dim objFolder As Outlook.MAPIFolder
　　Dim i As Integer
　　Dim j As Integer
　　Dim strSaveFolder As String
　　Dim strCsvFolder As String
　　Dim strXLSPath As String
　　Dim objXLS　As Object
　　Dim objBook As Object
　　Dim ShName(1 To 2) As String
　　Dim HeaderItem(1 To 2) As String
　　
　　' 準備
　　strSaveFolder = SAVE_FOLDER　　' Desktop を取得するのが本筋。
　　strCsvFolder = strSaveFolder & "\Work\"
　　strXLSPath = strSaveFolder & "\出荷データ_" & Format(Date, "yyyymmdd") & ".xlsx"
　　
　　ShName(1) = SHEET_A
　　ShName(2) = SHEET_B
　　HeaderItem(1) = ITEM_A
　　HeaderItem(2) = ITEM_B
　　
　　' 出力用Excelファイル作成
　　Set objXLS = CreateObject("Excel.Application")
　　Set objBook = objXLS.Workbooks.Add
　　With objBook
　　　　objBook.Worksheets.Add Before:=.Worksheets(1), Count:=2
　　　　For i = 1 To 2
　　　　　　.Worksheets(i).Name = ShName(i)
　　　　　　.Worksheets(i).Range("A1") = HeaderItem(i)
　　　　　　.Worksheets(i).Range("A1").TextToColumns Comma:=True
　　　　Next
　　　　For i = .Worksheets.Count To 3 Step -1
　　　　　　.Worksheets(i).Delete
　　　　Next
　　
　　End With
　　
　　objXLS.Visible = True
　　
　　' OutLook の選択されているフォルダのメールを処理する。
　　Set objFolder = Application.ActiveExplorer.CurrentFolder
　　Set objItems = objFolder.Items
　　objItems.Sort "[受信日時]", False　'False(昇順),True(降順)
　　'
　　For i = 1 To objItems.Count
　　　　With objItems(i)
　　　　　　Debug.Print i, .SenderName, .ReceivedTime
　　　　　　' Workフォルダ内の csvファイルを削除
　　　　　　On Error Resume Next
　　　　　　Kill strCsvFolder & "*.csv"
　　　　　　On Error GoTo 0
　　　　　　' 添付ファイルがあれば Workフォルダに保存する
　　　　　　If .Attachments.Count > 0 Then
　　　　　　　　For j = 1 To .Attachments.Count
　　　　　　　　　 .Attachments(j).SaveAsFile strCsvFolder & .Attachments(j).DisplayName
　　　　　　　　Next
　　　　　　　　' 保存した CSVファイルを Excel に取り込む。
　　　　　　　　Call CSV_Inport(objBook, ShName(), strCsvFolder)
　　　　　　End If
　　　　End With
　　Next i
　　
　　' 同名の Excelファイルが存在すれば削除する
　　If Dir(strXLSPath) <> "" Then
　　　　Kill strXLSPath
　　End If
　　 
　　'後始末。 　Excel を閉じる場合はコメントを外す。
　　objBook.SaveAs strXLSPath
'　　objBook.Close False
　　Set objBook = Nothing
'　　objXLS.Quit
　　Set objXLS = Nothing
　　
End Sub

Private Function CSV_Inport(objBook As Object, sh() As String, Path As String)
　　Dim i　 As Integer
　　Dim LastRow As Long
　　Dim strCSVPath　　As String
　　On Error Resume Next
　　For i = 1 To 2
　　　　With objBook.Worksheets(i)
　　　　　　LastRow = .Cells(.Rows.Count, 1).End(-4162).Row　　 ' -4162 = xlUp
　　　　　　strCSVPath = Path & sh(i) & ".csv"
　　　　　　
　　　　　　With .QueryTables.Add(Connection:= _
　　　　　　　　"TEXT;" & strCSVPath, Destination:=.Cells(LastRow + 1, "A"))
　　　　　　　　.FieldNames = False
　　　　　　　　.AdjustColumnWidth = True
　　　　　　　　.TextFilePlatform = 932
　　　　　　　　.TextFileParseType = 1　　　' xlDelimited
　　　　　　　　.TextFileTextQualifier = 1　' xlTextQualifierDoubleQuote
　　　　　　　　.TextFileConsecutiveDelimiter = False
　　　　　　　　.TextFileTabDelimiter = False
　　　　　　　　.TextFileSemicolonDelimiter = False
　　　　　　　　.TextFileCommaDelimiter = True
　　　　　　　　.Refresh BackgroundQuery:=False
　　　　　　　　.Delete
　　　　　　End With
　　　　End With
　　Next
End Function

Qchan1962 · Answer

＃１４変更に伴い

Excel部分CSV_Inportを変更しました。
’　　　変更箇所は適時変更してください。

Sub CSV_Inport(Folder_Path As String, flg As Boolean)
Dim strPath() As String
Dim File_Name As String, sh_Name As String
Dim dataRow As Long, qtRow As Long, qtCol As Long
Dim heading_items As Variant, Ws1 As Variant
Const CsvA As String = "AA"　　 '共通CSVファイル名A変更箇所
Const CsvB As String = "BB"　　 '共通CSVファイル名B変更箇所
Const ShNameA As String = "出荷まとめA" 'シート名A変更箇所
Const ShNameB As String = "出荷まとめB" 'シート名B変更箇所
　　 i = 1
　　 File_Name = Dir(Folder_Path & "\*" & ".csv")
　　 If File_Name = "" Then GoTo ErrorHandler
　　 Do While File_Name <> ""
　　　　　　 If File_Name Like "*" & ".csv" Then
　　　　　　　　 ReDim Preserve strPath(1 To i)
　　　　　　　　 strPath(i) = Folder_Path & "\" & File_Name
　　　　　　　　 i = i + 1
　　　　　　 End If
　　　　　　 File_Name = Dir()
　　 Loop
　　 OFF_ScreenUpdat
　　 On Error GoTo ErrorSheet
　　 Worksheets(ShNameA).Cells.ClearContents
　　 Worksheets(ShNameB).Cells.ClearContents
　　 For i = 1 To UBound(strPath)
　　　　　　 If strPath(i) Like "*" & CsvA & "*.csv" Or strPath(i) Like "*" & CsvB & "*.csv" Then
　　　　　　　　 If strPath(i) Like "*" & CsvA & "*.csv" Then sh_Name = ShNameA
　　　　　　　　 If strPath(i) Like "*" & CsvB & "*.csv" Then sh_Name = ShNameB
　　　　　　 Else
　　　　　　　　 sh_Name = ""
　　　　　　 End If
　　　　　　 If sh_Name <> "" Then
　　　　　　　　 Import_QT (strPath(i))
　　　　　　　　 qtRow = Worksheets("Work").Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　　　 qtCol = Worksheets("Work").Cells(1, Columns.Count).End(xlToLeft).Column
　　　　　　　　 dataRow = Worksheets(sh_Name).Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　　　 Worksheets("Work").Range(Cells(1, 1), Cells(qtRow, qtCol)).Copy Worksheets(sh_Name).Range("A" & dataRow + 1)
　　　　　　　　 Application.CutCopyMode = False
　　　　　　　　 Worksheets("Work").Cells.Delete
　　　　　　 End If
　　 Next
　　 heading_items = Array("日付", "担当", "品名", "住所", "品名", "金額", "備考") '変更箇所
　　 Worksheets(ShNameA).Range("A1").Resize(, UBound(heading_items) + 1) = heading_items
　　 Worksheets(ShNameB).Range("A1").Resize(, UBound(heading_items) + 1) = heading_items
　　 Ws1 = Array(ShNameA, ShNameB)
　　 Call NewFile_Save(Ws1)
errany:
　　 ON_ScreenUpdat
　　 Exit Sub
ErrorHandler:
　　 MsgBox "対象のファイルが登録できませんでした。" & Chr(13) & "エラー" & Err.Number & Chr(13) & Err.Description
　　 flg = False
　　 GoTo errany
ErrorSheet:
　　 MsgBox "シート書き出しでエラーが発生しました。以下を確認してください。" & Chr(13) & "シート名　Work、" & _
　　　　　　　　 ShNameA & "、" & ShNameB & " が必要です。" & Chr(13) & "エラー" & Err.Number & Chr(13) & Err.Description
　　 flg = False
　　 GoTo errany
End Sub

他のプロシージャはそのまま使います。（Move_mailは不要）

何度か私の環境で実行しローカルウオッチしました。メール名などが適切であれば動くかと思います。
エラーが発生した場合は、さらに連絡、結果をお知らせいただければと思います。

Qchan1962 · Answer

>本当は別のアカウントにサブフォルダを作りたいです。
https://stackoverflow.com/questions/33953386/vba-to-select-mailbox-if-an-account-has-multiple-mailboxs
こちらのサイトにあるコードを参考に作成しました。ので再度、VBAを上書きしてください。それに伴い、エラー処理や一部構成も変えましたので
こちらで、試してみてください。
アカウントは、部分を実際のものを入力して受信トレイと同じレベルに出荷報告フォルダ、処理済み出荷報告フォルダを作成してください。

’Outlook部分

Option Explicit
Dim outlookObj As Outlook.Application
Dim myNameSpace As Object, objmailItem As Object
Dim i As Long
Sub Outlook_csv_integration()
Dim fldr As Folder, InboxFolder As Folder, DoneFolder As Folder
Dim oAccount As Account
Dim MyExplorer As Object
Dim Attcount As Long, j As Long
Dim path1 As String, flg As Boolean
Dim fso As FileSystemObject
　　 Set outlookObj = CreateObject("Outlook.Application")
　　 Set myNameSpace = outlookObj.GetNamespace("MAPI")
　　 On Error GoTo ErrOutlook
　　 For Each oAccount In outlookObj.Session.Accounts
　　　　　　 For Each fldr In myNameSpace.Folders
　　　　　　　　 If fldr = "xxxxx@xxxxxxx.com" Then '変更箇所（必須）
　　　　　　　　　　　　 Set InboxFolder = fldr.Folders("出荷報告")
　　　　　　　　　　　　 Set DoneFolder = fldr.Folders("処理済み出荷報告")
　　　　　　　　　　　　 Exit For
　　　　　　　　 End If
　　　　　　 Next
　　 Next
　　 path1 = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\" & "TmpVBA_Work"
　　 Set fso = CreateObject("Scripting.FileSystemObject")
　　 If fso.FolderExists(path1) Then
　　　　　　 fso.DeleteFolder path1
　　　　　　 fso.CreateFolder (path1)
　　 Else
　　　　　　 fso.CreateFolder (path1)
　　 End If
　　 MsgBox ("対象メール数 : " & InboxFolder.Items.Count)
　　 For i = 1 To InboxFolder.Items.Count
　　　　　　 Set objmailItem = InboxFolder.Items(i)
　　　　　　 Attcount = objmailItem.Attachments.Count
　　　　　　 If Attcount > 0 Then
　　　　　　　　 For j = 1 To Attcount
　　　　　　　　　　　　 objmailItem.Attachments(j).SaveAsFile (path1 & "\" & i & objmailItem.Attachments(j).DisplayName)
　　　　　　　　 Next
　　　　　　 End If
　　 Next
　　 flg = True
　　 Call CSV_Inport(path1, flg)
　　 If flg = False Then GoTo ErrExcel
　　 For i = InboxFolder.Items.Count To 1 Step -1
　　　　　　 Set MyExplorer = InboxFolder.Items(i)
　　　　　　 MyExplorer.Move DoneFolder
　　 Next i
　　 fso.DeleteFolder path1
　　 MsgBox ("終了しました")
ErrTr:
　　 Set outlookObj = Nothing
　　 Set myNameSpace = Nothing
　　 Set InboxFolder = Nothing
　　 Set fso = Nothing
　　 Exit Sub
ErrOutlook:
　　 MsgBox "Outlook設定" & Chr(13) & "エラー" & Err.Number & Chr(13) & Err.Description
　　 GoTo ErrTr
ErrExcel:
　　 GoTo ErrTr
End Sub

'---まで

以下不要の為削除

Sub Move_mail()
Dim TargetFolder As Object
Dim DoneFolder As Object
Dim MyExplorer As Object
Set outlookObj = CreateObject("Outlook.Application")
Set myNameSpace = outlookObj.GetNamespace("MAPI")
Set TargetFolder = myNameSpace.GetDefaultFolder(6).Folders("出荷報告")
Set DoneFolder = myNameSpace.GetDefaultFolder(6).Folders("処理済み出荷報告")
For i = TargetFolder.Items.Count To 1 Step -1
Set MyExplorer = TargetFolder.Items(i)
MyExplorer.Move DoneFolder
Next i
Set outlookObj = Nothing
Set myNameSpace = Nothing
Set TargetFolder = Nothing
Set DoneFolder = Nothing
End Sub

まで-----------

Qchan1962 · Answer

別途質問なのですが、
OUTLOOKで複数（5つ）のアカウントを使っている場合、既定のアカウントにサブフォルダを作らないと選択できないでしょうか。
何度かトライしてみて、既定のアカウントのサブフォルダだと先に進めましたが、本当は別のアカウントにサブフォルダを作りたいです。

これについては、おっしゃる通りですね。別のアカウントにサブフォルダにと言う事であれば、多少は、知識はありましたが、化石化しており
ほぼこの件でExcel　VBAでOutlook操作をしています、、、テスト環境を作る為Outlook入れたくらいなので、現在の私には無理かと思います。

今後もOutlook使う可能性はかなり低いので、、と言う感じです。とは言っても自分の為にもなるので少し調べてみますが、、お約束できません。

Qchan1962 · Answer

やはり、と言う感じですが。取敢えず、エラーの対処を示します。
おそらく、配列にファイルpathが登録されなかったのが原因です。
配列は、通常0から始まりますが、ループ変数をファイルの名前に付けよかと思って当初行っていましたのでそのままにしていました。
それに問題がある訳ではありませんが、配列のインデックスをファイル登録時に与えているので登録されないとエラーになります。
登録される事が前提で作った͡事に原因があります。

しかし、根本的には、なぜ登録されないのかにあります。

メッセージボックスで対象メール数と表示がありOKを押すと思いますが、数値は入っていましたか？入っていれば、
対象のフォルダに設定した共通文字を含むCSVファイルは、間違いなくありますか？確認をお願いします。
また、エラーで止まったのであればデスクトップにTmpVBA_Work　フォルダが作られていると思いますが、
中には共通文字を含むCSVファイルはありますでしょうか？ご確認ください。抽出時にファイルの頭に整数が振られています。

手数を掛けますが、エラーの処理コードを足してください。
Sub CSV_Inport(Folder_Path As String)プロシージャ内

If IsEmpty(strPath) Then Exit Sub
On Error GoTo ErrorHandler　　　これを追加します
For i = 1 To UBound(strPath)　　エラーになるところ
・
・
Call NewFile_Save(Ws1)
errany:
ON_ScreenUpdat　　この下に4行追加

Exit Sub
ErrorHandler:
MsgBox "対象のファイルが登録できませんでした。" & Chr(13) & "エラー" & Err.Number & Chr(13) & Err.Description
GoTo errany

End Sub

エラーになった場合エラー内容が表示され終了します。

作成されているTmpVBA_Workフォルダを確認してください。

Qchan1962 · Answer

変更箇所は、前に説明した箇所です。コメントアウトしている箇所です同じモジュールへ書いてください。（文字数制限で変数外に出しました）この下から Sub CSV_Inport(Folder_Path As String) Dim strPath() As String Dim File_Name As String, sh_Name As String Dim temp As Variant Dim dataRow As Long, qtRow As Long, qtCol As Long Dim heading_items As Variant, Ws1 As Variant Const CsvA As String = "AA" '共通CSVファイル名A変更箇所 Const CsvB As String = "BB" '共通CSVファイル名B変更箇所 Const ShNameA As String = "AAA" 'シート名A変更箇所 Const ShNameB As String = "BBB" 'シート名B変更箇所 i = 1 If Folder_Path = "" Then Exit Sub File_Name = Dir(Folder_Path & "\*" & ".csv") Do While File_Name <> "" If File_Name Like "*" & ".csv" Then ReDim Preserve strPath(i) strPath(i) = Folder_Path & "\" & File_Name i = i + 1 End If File_Name = Dir() Loop If IsEmpty(strPath) Then Exit Sub For i = 1 To UBound(strPath) temp = strPath(i) j = i - 1 Do If (j < 0) Then Exit Do End If If (strPath(j) <= temp) Then Exit Do End If strPath(j + 1) = strPath(j) j = j - 1 Loop strPath(j + 1) = temp Next j = 0 OFF_ScreenUpdat Worksheets(ShNameA).Cells.ClearContents Worksheets(ShNameB).Cells.ClearContents For i = 1 To UBound(strPath) sh_Name = "" If strPath(i) Like "*" & CsvA & "*" & ".csv" Then sh_Name = ShNameA If strPath(i) Like "*" & CsvB & "*" & ".csv" Then sh_Name = ShNameB If sh_Name <> "" Then Import_QT (strPath(i)) qtRow = Worksheets("Work").Cells(Rows.Count, 1).End(xlUp).Row qtCol = Worksheets("Work").Cells(1, Columns.Count).End(xlToLeft).Column dataRow = Worksheets(sh_Name).Cells(Rows.Count, 1).End(xlUp).Row Worksheets("Work").Range(Cells(1, 1), Cells(qtRow, qtCol)).Copy Worksheets(sh_Name).Range("A" & dataRow + 1) Application.CutCopyMode = False Worksheets("Work").Cells.Delete j = j + 1 End If Next If j = 0 Then GoTo errany heading_items = Array("日付", "担当", "品名", "住所", "品名", "金額", "備考") '変更箇所 Worksheets(ShNameA).Range("A1").Resize(, UBound(heading_items) + 1) = heading_items Worksheets(ShNameB).Range("A1").Resize(, UBound(heading_items) + 1) = heading_items Ws1 = Array(ShNameA, ShNameB) Call NewFile_Save(Ws1) errany: ON_ScreenUpdat End Sub Sub Import_QT(vntFileName As String) If VarType(vntFileName) = vbBoolean Then Exit Sub If vntFileName = "" Then Exit Sub On Error Resume Next Worksheets("Work").Activate Worksheets("Work").Cells.Delete With Worksheets("Work").QueryTables.Add(Connection:="text;" & vntFileName, Destination:=Range("A1")) .TextFilePlatform = 932 .TextFileCommaDelimiter = True .Refresh BackgroundQuery:=False .Delete End With End Sub Sub NewFile_Save(Ws1 As Variant) Dim SheetName As Variant Dim dateName As String Dim fpath As String, MYPATH As String MYPATH = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\" dateName = Format(Date, "yyyymmdd") For i = 0 To 1 SheetName = dateName & Ws1(i) With Workbooks.Add ThisWorkbook.Worksheets(Ws1(i)).Copy , .Worksheets(.Worksheets.Count) ActiveSheet.Name = SheetName .Worksheets(.Worksheets.Count).Activate Sheets(1).Delete .SaveAs (MYPATH & SheetName & ".xlsx") .Close False End With ThisWorkbook.Activate Next End Sub Private Sub OFF_ScreenUpdat() With ThisWorkbook.Application .ScreenUpdating = False .DisplayAlerts = False .EnableEvents = False End With End Sub Private Sub ON_ScreenUpdat() With ThisWorkbook.Application .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True End With End Sub

OUTLOOK VBA 指定フォルダ内のメール添付ファイル2つをエクセルのシートにまとめるマクロ

おおっと！！ 確かに拡張子大文字にできるけど、、勉強になりました。

色々な検証有難うございます。

私のテスト環境でエラーが出ないので苦戦しております。

#15情報に対して

横から失礼します。

＃１４変更に伴い

>本当は別のアカウントにサブフォルダを作りたいです。

別途質問なのですが、

やはり、と言う感じですが。

変更箇所は、前に説明した箇所です。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おおっと！！　確かに拡張子大文字にできるけど、、勉強になりました。