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

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形式ですぐにつまずきました。どうぞよろしくお願いいたします。

No.10 回答者： Qchan1962 回答日時： 2019/10/10 18:19

何度も手を煩わせてしまったかと思います。

OutlookもExcel側から操作してすべて実行します。VBSも使えるかもですが、取り敢えず忘れてください。
全て見直ししましたので此方のコードで試してみてください。
Excel　VBA側にすべて書きますExcelの同じ標準モジュールに記載してください。

参照設定は、Microsoft Outlook xx.x Object Library　と　Microsoft Scripting Runtime　にチェックを入れてください
実行プロシージャは　Outlook_csv_integration　です。
コード内の"出荷報告"、"処理済み出荷報告"はOutlookに設定したサブフォルダ名です。
エラー処理はほぼありませんのでエラーが出る場合はお知らせください。
空文字などのエラーは一応書いておきましたが空CSVの対応はOn Error Resume Nextです。
全てが終了するとメールは処理済み出荷報告フォルダに移動されます。
デスクトップに日付Aシート名と日付Bシート名のExcelファイルが作成されます。

仕様には条件（変更可）があります。
Outlook受信トレイにサブフォルダ　出荷報告と処理済み出荷報告を作成してください。
対象のメールは出荷報告フォルダに自動で振り分けられるように設定してください。（テスト時はこのフォルダに対象のメールを置いてください）

Sub Outlook_csv_integration()は、Outlookの添付ファイルを番号を付けて保存しています。
Sub Move_mail()は、処理の終盤に処理済み出荷報告フォルダにメールを移動しています。
次のページ
Sub CSV_Inport(Folder_Path As String)は、CSVファイルの集計など
Sub Import_QT(vntFileName As String)は、クエリテーブルでCSVを抽出してます。
Sub NewFile_Save(Ws1 As Variant)は、シートを新規ブックで保存
Private Sub OFF_ScreenUpdat()　と　Private Sub ON_ScreenUpdat()は、画面制御系です。

長いので2回に分けて掲示します。（文字数になるのでイデントは付けません）

ここから下がコード

Option Explicit
Dim outlookObj As Outlook.Application
Dim myNameSpace As Object, objmailItem As Object
Dim i As Long, j As Long

Sub Outlook_csv_integration()
Dim InboxFolder As Variant
Dim Attcount As Long
Dim path1 As String
Dim fso As FileSystemObject
Set outlookObj = CreateObject("Outlook.Application")
Set myNameSpace = outlookObj.GetNamespace("MAPI")
Set InboxFolder = myNameSpace.GetDefaultFolder(6).Folders("出荷報告")
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
Set outlookObj = Nothing
Set myNameSpace = Nothing
Set InboxFolder = Nothing
Call CSV_Inport(path1)
Call Move_mail
fso.DeleteFolder path1
Set fso = Nothing
MsgBox ("終了しました")
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

上まで、、続く

No.9 回答者： Qchan1962 回答日時： 2019/10/09 21:18

メモ帳で保存する際にUnicodeで保存してみてください。

https://mulanmagnolia.net/245.html

No.8 回答者： Qchan1962 回答日時： 2019/10/09 20:44

VBS　ダメですよね。

私の理解が浅かったです。
時間をください。

No.7 回答者： Qchan1962 回答日時： 2019/10/09 20:27

>UBound(strPath) = 0 Thenの箇所が黄色マーカーされています。

毎度すみません。よろしくお願いいたします。

すみません。なんでこんなの書いたのか、コードまちがっています。。
フォルダ内にファイルがない時は、配列にファイルパスは入れませんのでUBoundはエラーです。

言い訳出来ない初歩的なミスです。
コメントを入れた（消えたコードは修正したのにです。。）

If IsEmpty(strPath) = False Then Exit Sub　が正解です。書き直してください。
しかし、空のフォルダ指定したのかな？

VBSは、
見直しました。私のローカルではうまく実行されましたが、いかがでしょう。

ファルダの場所は、デスクトップ限定になります。一応　出荷まとめフォルダで試しました。

スキル不足で手数をかけますが、確認してください。

Option Explicit
'https://www.ka-net.org/blog/?p=6455
Dim args
Dim olApp
Dim i
Dim ix
Dim SaveFolderPath
ix = 1
SaveFolderPath = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\" & "出荷まとめ"
Set args = WScript.Arguments
If args.Count < 1 Then
MsgBox "msgファイルを当スクリプトファイルにドラッグ＆ドロップしてください。", vbExclamation + vbSystemModal
WScript.Quit
End If
ix=1
With CreateObject("Scripting.FileSystemObject")
If .FolderExists(SaveFolderPath) = False Then
MsgBox "添付ファイルの保存先フォルダが見つかりませんでした。" & vbCrLf & _
"処理を中止します。", vbCritical + vbSystemModal
WScript.Quit
End If
Set olApp = CreateObject("Outlook.Application")
For i = 0 To args.Count - 1
If .FileExists(args(i)) = True Then
Select Case LCase(.GetExtensionName(args(i)))
Case "msg" 'msgファイルのみ処理
SaveMsgAttachments olApp, args(i), AddPathSeparator(SaveFolderPath), ix
ix=ix+1
End Select
End If
Next
olApp.Quit
End With

MsgBox "処理が終了しました。", vbInformation + vbSystemModal

Private Sub SaveMsgAttachments(ByVal OutlookApp, ByVal MsgFilePath, ByVal SaveFolderPath, ByVal ix)
Dim itm 'Outlook.MailItem
Dim atc 'Outlook.Attachment
Dim fn

With OutlookApp.GetNamespace("MAPI")
Set itm = .OpenSharedItem(MsgFilePath)
Select Case LCase(TypeName(itm))
Case "mailitem"
If itm.Attachments.Count < 1 Then
MsgBox "添付ファイルがありません。" & vbCrLf & _
"(ファイル名：" & MsgFilePath & ")", vbExclamation + vbSystemModal
Exit Sub
Else
With CreateObject("Scripting.FileSystemObject")
For Each atc In itm.Attachments
fn = SaveFolderPath &ix& atc.FileName
If .FileExists(fn) = True Then
.DeleteFile fn, True '同名のファイルがあったら事前に削除
End If
atc.SaveAsFile fn
Next
End With
End If
End Select
End With
End Sub

Private Function AddPathSeparator(ByVal s)
If Right(s, 1) <> ChrW(92) Then s = s & ChrW(92)
AddPathSeparator = s
End Function

No.6 回答者： Qchan1962 回答日時： 2019/10/08 19:06

OutlookのVBAいじる方が良いかもしれませんが、

こちらで
https://www.ka-net.org/blog/?p=6455

よさそうなVBSを見つけたので、拝借して少し改造を加えて使うのはどうでしょう。
参考サイトをご覧ください。
投げ込む前の選択順番を工夫してください。多分選択順で採番が変わるかと思います。未検証

改造したvbs

2か所を変更してください。"E:\Desktop\AAA" これはダミーです。実在するフォルダパス
SaveFolderPath = "E:\Desktop\AAA\"のE:\Desktop\AAA　上と同じパスで。最後の￥忘れずに。
下をメモ帳にコピペ

Dim args
Dim olApp
Dim ix
Const SaveFolderPath = "E:\Desktop\AAA" '＊要変更、添付ファイルの保存先フォルダパス
Set args = WScript.Arguments
If args.Count < 1 Then
MsgBox "msgファイルを当スクリプトファイルにドラッグ＆ドロップしてください。", vbExclamation + vbSystemModal
WScript.Quit
End If
ix = 1
With CreateObject("Scripting.FileSystemObject")
If .FolderExists(SaveFolderPath) = False Then
MsgBox "添付ファイルの保存先フォルダが見つかりませんでした。" & vbCrLf & _
"処理を中止します。", vbCritical + vbSystemModal
WScript.Quit
End If
Set olApp = CreateObject("Outlook.Application")
For i = 0 To args.Count - 1
If .FileExists(args(i)) = True Then
Select Case LCase(.GetExtensionName(args(i)))
Case "msg" 'msgファイルのみ処理
SaveMsgAttachments olApp, args(i), AddPathSeparator(SaveFolderPath)
End Select
End If
Next
olApp.Quit
End With
MsgBox "処理が終了しました。", vbInformation + vbSystemModal
Private Sub SaveMsgAttachments(ByVal OutlookApp, ByVal MsgFilePath, ByVal SaveFolderPath)
Dim itm 'Outlook.MailItem
Dim atc 'Outlook.Attachment
Dim fn
Dim i
With OutlookApp.GetNamespace("MAPI")
Set itm = .OpenSharedItem(MsgFilePath)
Select Case LCase(TypeName(itm))
Case "mailitem"
If itm.Attachments.Count < 1 Then
MsgBox "添付ファイルがありません。" & vbCrLf & _
"(ファイル名：" & MsgFilePath & ")", vbExclamation + vbSystemModal
Exit Sub
Else
With CreateObject("Scripting.FileSystemObject")
For Each atc In itm.Attachments
Dim objRE
Set objRE = CreateObject("VBScript.RegExp")
objRE.Pattern = ".*"
If objRE.Test(atc.Filename) Then
SaveFolderPath = "E:\Desktop\AAA\" & ix　　’＊要変更AAA最後の￥忘れずに
ix=ix+1
End If
Set objRE = Nothing
fn = SaveFolderPath & atc.Filename
If .FileExists(fn) = True Then
.DeleteFile fn, True '同名のファイルがあったら事前に削除
End If
atc.SaveAsFile fn
Next
End With
End If
End Select
End With
End Sub
Private Function AddPathSeparator(ByVal s)
If Right(s, 1) <> ChrW(92) Then s = s & ChrW(92)
AddPathSeparator = s
End Function

上まで---

メモ帳を取敢えず保存し拡張子をvbsに変更します。警告は無視します。
デスクトップにあるアイコンに該当のメールをまとめてドロップしてください。
フォルダは、事前に作っておきます。また、中は空にしておいてくださいね。

この回答へのお礼

色々教えていただき本当にありがとうございます！！！

メモ帳を保存してvbsに拡張子を変更して、2か所変更しました。メールをまとめてドロップすると、
エラーメッセージがでます。
スクリプト：C:\Users\user122\Desktop\フォルダ移動.vbs
行：4
文字：61
エラー：終了していない文字列型の定数です。
コード：800A0409
ソース：Microsoft VBScript コンパイルエラー
2か所変更した部分があやしそうなのですが、いろいろ変えてみてもダメです。。

Dim args
Dim olApp
Dim ix
Const SaveFolderPath = "C:\Users\user122\Desktop\出荷まとめ"
Set args = WScript.Arguments

お礼日時：2019/10/09 15:09

No.5 回答者： Qchan1962 回答日時： 2019/10/07 21:13

ゴメンナサイ！コード内に書いた説明、、文字オーバーでコピペしたら消えてしまった、、、どこにもない！！！なえそう、、

＃３から、、
Const CsvA As String = "AAA" 'CSVファイル名A
Const CsvB As String = "BBB" 'CSVファイル名A
Const ShNameA As String = "AAA" 'シート名A
Const ShNameB As String = "BBB" 'シート名B

ここの””内を変更します。
Const CsvA As String = "AAA" 'CSVファイル名A　CSVの共通のファイル名　

Const ShNameA As String = "AAA" 'シート名A　これは、出力されるExcelのファイル名にもなりますこのままだと、20191007AAA.xlsx です。

heading_items = Array("日付", "担当", "品名", "住所", "品名", "金額", "備考")
これは、見出し項目です。A,B共通。　増やす場合は、増減する場合は、形を変えずの　"備考","~","～","～～"　半角、全角を気を付けてください。 "全角表示文字" 他は、半角

コードの説明、採用した意図など、、消えた、、最低限の説明ですみません。なえ。。。

気になる点や不具合などあれば補足してください。。。

あと、これけしてください。　Debug.Print strPath(i); sh_Name; dataRow　デバックの跡です。。

No.4 回答者： Qchan1962 回答日時： 2019/10/07 20:54

’続き---------

Sub NewFile_Save(Ws1 As Variant)
Dim i As Long
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.Activate
　　　　 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

ここまで

本来？のCSV抽出のやり方だと対象のシートに順次書いていきますが、
このコードはクエリテーブルを使って抽出、別シートにコピーを繰り返しています。
ちょっと、邪道かもしれませんが、ツールなどにして大きいデータを扱う場合に効果があります。
本来、セルへの書き込みは、メモリを消費して速度も遅いのですが、この場合、処理は早いかと、、
小さいデータの繰り返しだと、むしろ遅いかも、、、です。後々にはこちら良いと判断しました。、、はず。

集計後にAAA,BBBのシート上にデータが残っていますので（本日分）集計などを他のシートで行えます。
関数でやるか、VBAでやるかは、仕様に応じて考えてください。また、各シートは、実行の度、クリアーされたりしますので、
集計などを行う場合は、別にシートを追加してください。

示してみてください。
取り合えず、、、、

この回答へのお礼

CSV_Inportを実行してみました。CSVの入っているフォルダを選択してOKを押すと、実行時エラー”9”インデックスが有効範囲にありません。というメッセージがでます。デバッグをクリックするとIf UBound(strPath) = 0 Thenの箇所が黄色マーカーされています。毎度すみません。よろしくお願いいたします。

お礼日時：2019/10/09 14:00

No.3 回答者： Qchan1962 回答日時： 2019/10/07 20:51

文字数オーバーになってしまったので、分けて投稿します。

CSV大丈夫みたいですね。
添付ファイルの振り分けや抽出はひとまず、置いときます。管理ツールとしてのファイル作りのやりたい事や校正の整理が必要なので
当初のExcelファイルにまとめて保存する。のコードを考えます。後からまとまったCSVからの必要データを抽出して云々をある程度考慮した方が良いでしょう。
初めから、疑問になっていたのですが、1日分の添付ファイル名はすべて同じなのですか？相手方送信時間などで名前を付けられるのでしょうか？番号でも良いですが、、

不明点もありますので、ファイルはVBAに合わせる形で作成してください。

先ず、抽出するCSVは　出荷AAA.csv、出荷BBB.csv共に同じフォルダに入れてください。つまり、同名ではなくなりますので、変わらない名前+番号や番号+変わらない名前などです。
昇順にソートしますので古いのから1、2、3、、、、の様に
この作業は、OutlookかExcelからOutlookを操作する形で行いたいのですが、Outlookに関してはあまり分からないので、、先に記したように取り敢えずペンディングします。

CSVデータの抽出環境が決まりました（無理くり）ので、抽出してExcelのファイルを作るコードを示します。

新しいBookを作成して、シートを3枚にします。名前は、コードに合わせても良いですし、コードをシート名に合わせても良いです。
Book名は問いません。
コードではシート名

Work　作業用です。ツールに改造する事をふまえてます。
AAA　出荷AAA.csvを纏めて日付+シート名でExcelを出力します。
BBB　上記同様です。

VBEを表示して標準モジュールを挿入してください。
ここで、一旦名前を付けて保存します。場所も問いません。

モジュールにコードをコピペしてください。
変更する場所などは、コード内にコメントで記すので理解出来たらさくじょしてOKです。

実行プロシージャは、CSV_Inportです。

Option Explicit
Sub CSV_Inport()
Dim strPath() As String, Folder_Path As String
Dim File_Name As String, sh_Name As String
Dim temp As Variant, i As Long, j As Long
Dim dataRow As Long, qtRow As Long, qtCol As Long
Dim heading_items As Variant, Ws1 As Variant

Const CsvA As String = "AAA" 'CSVファイル名A
Const CsvB As String = "BBB" 'CSVファイル名A
Const ShNameA As String = "AAA" 'シート名A
Const ShNameB As String = "BBB" 'シート名B
　 i = 1
　 With Application.FileDialog(msoFileDialogFolderPicker)
　　　 .Title = "　CSVの入っているフォルダを選択してください"
　　　 .InitialFileName = ThisWorkbook.Path
　　　 If .Show = True Then
　　　　 Folder_Path = .SelectedItems(1) & "\"
　　　 End If
　 End With
　 If Folder_Path = "" Then Exit Sub
　 File_Name = Dir(Folder_Path & "*" & ".csv")
　 '　　 On Error Resume Next
　 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 UBound(strPath) = 0 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
　　　　 Application.CutCopyMode = False
　　　　 Worksheets("Work").Cells.Delete
　　　　 j = j + 1
Debug.Print strPath(i); sh_Name; dataRow
　　　 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
　 Worksheets("Work").Activate
　 ActiveSheet.Cells.Delete
　 With ActiveSheet.QueryTables.Add(Connection:="text;" & vntFileName, Destination:=Range("A1"))
　　　 .TextFilePlatform = 932 'Shift=Jis
　　　 .TextFileCommaDelimiter = True
　　　 .Refresh BackgroundQuery:=False
　　　 .Delete
　 End With
End Sub

No.2 回答者： Qchan1962 回答日時： 2019/10/06 17:52

OUTLOOKで受信した時に添付ファイルを保存するVBAがあるようです。

大分古い記事ですが、、https://outlooklab.wordpress.com/2007/03/10/%E5% …
私は、OUTLOOK　ほぼ使わないので検証してませんが、、今のバージョンでどうなのかですね。すでにアドインとかあるのではないでしょうか。

出荷管理Excelみたいなものを作成すれば良いかと、データ分析や実績評価などやりたい事が増えて行くかもしれませんが、、その時にコードを追加して対応するなどで
となると、すべては、元になるデータ（CSV）の内容です。と言う事で、

csvの内容が加工などせずに扱えるか確認したいのですが、
テキスト形式か、文字化けや、改行コード、全角半角スペース、ダブル（シングル）コーテーションなど

下記にcsvファイルをExcelシートに抽出するマクロを書きます。
VBAの導入方法やデバック（言語的に問題ないか確かめる）など基本的な知識を付けて行くとこが必要になります。
Excelの標準モジュールにコピペしてください。
空のシートを選択して、VBEが出たままで良いので、F５などで実行してください。
実行するとUIでファイルを聞かれるので、該当CSVを選んでください。

このコードは、複数のCVSを同じシートに書き出すことは出来ないので使用しないと思います。処理が早いので状況によりですが、、
Deleteと言う怖い文字がありますが、これはシートのセルに対してすべてを削除する命令です。
データのある（消してはいけない）シートで事項しないでください。

Sub Csv_Test_import()
Dim vntFileName As String
Dim xlAPP As Application
　　Set xlAPP = Application
　　vntFileName = xlAPP.GetOpenFilename(FileFilter:="抽出ファイル (*.csv),*.csv", Title:="ファイル読み込み処理")
　　If VarType(vntFileName) = vbBoolean Then Exit Sub
　　If vntFileName = "" Then Exit Sub
　ActiveSheet.Cells.Delete
　　With ActiveSheet.QueryTables.Add(Connection:="text;" & vntFileName, Destination:=Range("A1"))
　　　.TextFilePlatform = 932 'Shift=Jis
　　　.TextFileCommaDelimiter = True
　　　.Refresh BackgroundQuery:=False
　　　.Delete
　　End With
End Sub

シートにCSVの内容が抽出されたと思いますが、、そのまま使えるデータですか？
文字は正しく表示されていますか？数値は数値として演算などできそうですか？
文字頭の0がないとか、番号のはずが、日付になっているとか、、、
確認してみてください。

この回答へのお礼

回答ありがとうございます。
頂いたマクロでエクセルに抽出して確認してみました。
文字化けせずにそのまま正しく、転送されていることを確認しました。
一瞬でした。。
よろしくお願いいたします。

お礼日時：2019/10/07 16:38

No.1 回答者： Qchan1962 回答日時： 2019/10/05 23:13

同様のツールを制作して使っていますが、ご質問にはいくつかのハードルがあります。

私の場合、CSV出力側も制作したので、CSVのファイル名が出荷AAA20191005_01などになっており発行されるたびに枝番号が増えていきます。
また、データ配列や内容も工夫しているので、文字化けなどの心配もありません。
したがって、同名がないのでフォルダにVBAを使って移動する際も手をかけず行えますし、添付ファイルの抽出保存した後に処理できます。
また、処理的にはCSVを保存してからすべてをExcelに抽出して作業、変更後のデータをCSV出力するだけで
抽出、変更、分析、プリント、PDF出力などは、また該当CSVを抽出すればよいのでExcelとして保存する意味がありませんので行ってません。

まあ、おいといて
ExcelにVBAを導入してOutlookを操作、受信フォルダ内の受信日時で当日受信分を
ターゲットにして添付ファイル名をキーに開き、Excelシートに抽出を繰り返し日付名でExcelを保存する。
出来そうですね。

しかし、この場合、処理自体ExcelとOutlookを行き来するので、インスタンスの維持、スタックや不具合のリスクを減らしたいので
出来れば先に添付ファイル全てをフォルダに保存したいですね。（多分必須になるかと）
しかし、2つの添付ファイルをそれぞれまとめて保存することは、先方送信時間を付けて分けますか？同じ名前保存できませんから。

＞エクセルシートのそれぞれ1行名にタイトル行も設定したい
簡単な事ですが、内容を記載しないと分かりません。

データ量もどのくらいですか、、量によっては工夫が必要かもですが、、
CSVの内容によってもてこずる可能性がありますし、
すんなり、これでとはならないと思うので分けてスレッド建てるなどした方が良いかもですね

Excel　バージョン　2016　190.... Outlookバージョン　2016　MSO　かな？

この回答へのお礼

確かに。エクセルで保存する必要はないですね。。。そのままcsv形式でまとめればいいと思いました。
日々のルーティンをそのまま実現する必要はないと。。
データ量は、多くてもまとめて20列100行くらいです。

お礼日時：2019/10/06 16:05