###前提・実現したいこと
マクロで取込データを、別データのフォーマットの項目でフィルターをかけ、
指定列ごとコピーしフォーマット側にペースト、
次の項目でフィルターをかけ、指定列ごとコピーしフォーマット側にペーストを繰り返し、
フォーマット側の項目がなくなったら次シートの項目でフィルターをかけて……
というループをさせ、最終シートまで繰り返す。
というマクロです。
このマクロを回し終わった後に、
シート毎に別々の人にメールを送る機能を追加したいのですが、
最短で送れる構文を作るとしたら、どうされますか?
一応、マスタを作成してそこから必要な情報取込、送信という処理をループさせようと考えています。
皆様の知恵をお貸しください。
よろしくお願いします。
Option Explicit Dim gyo As Long Dim gyo2 As Long Dim gyo3 As Long Dim filecount As Long Dim sheetcount As Long Dim unmatch As Long Dim erfilecount As Long 'ボタンを押したとき Sub FolderSelect() 'ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents 'ThisWorkbook.Worksheets(2).Range("B1:BE3005").ClearContents Dim folderpass As String With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then folderpass = .SelectedItems(1) Else ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。" Exit Sub End If End With filecount = 0 sheetcount = 0 unmatch = 0 erfilecount = 0 gyo = 6 gyo2 = 2 ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中" Call FileSearch(folderpass, "*.csv") Dim dateupdate As String dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新" 'ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate 'ThisWorkbook.Worksheets(2).Name = dateupdate ' ThisWorkbook.Worksheets(1).Range("B2").Value = "完了" ThisWorkbook.Worksheets(2).Activate End Sub 'ファイル検索 Sub FileSearch(Path As String, Target As String) Dim FSO As Object, Folder As Variant, File As Variant Set FSO = CreateObject("Scripting.FileSystemObject") For Each Folder In FSO.GetFolder(Path).SubFolders Call FileSearch(Folder.Path, Target) Next Folder For Each File In FSO.GetFolder(Path).Files If File.Name Like Target Then filecount = filecount + 1 ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path Call ParCopy(File.Path) gyo = gyo + 1 End If ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。" Next File End Sub ''一覧出力 Sub ParCopy(Path As String) Dim openbook As Workbook Dim openbooksheet As Worksheet Dim lp As Long Dim el As Long Dim br As String 'オ Dim c As Range, Target As Range Dim LastRow As Long '縦軸(マクロ側シート数用) lp = 2 '横軸(データ側ループ管理用) el = 3 Application.ScreenUpdating = False On Error GoTo myError Set openbook = Application.Workbooks.Open(Path) Set openbooksheet = openbook.Worksheets(1) openbooksheet.Unprotect Do Until lp = 28 Do Until ThisWorkbook.Worksheets(lp).Cells(1, el) = "" br = ThisWorkbook.Worksheets(lp).Cells(2, el) openbooksheet.Activate Selection.AutoFilter openbooksheet.Range("A1").AutoFilter Field:=8, Criteria1:=br LastRow = 291826 openbooksheet.Range("J2:J" & LastRow).Copy ThisWorkbook.Worksheets(lp).Range(ThisWorkbook.Worksheets(lp).Cells(3, el), ThisWorkbook.Worksheets(lp).Cells(3, el)) openbooksheet.Range("A1").AutoFilter el = el + 1 Loop el = 3 lp = lp + 1 Loop openbook.Close False Application.ScreenUpdating = True Exit Sub myError: MsgBox Err.Description ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生" erfilecount = erfilecount + 1 Application.ScreenUpdating = True End Sub
###補足情報
前回使用していたマクロを改変して作っているので謎の項目があるかもしれませんがご容赦ください。
回答2件
あなたの回答
tips
プレビュー
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2016/06/24 05:00