過去作成　ExcelVBA

Sub ee()
    Dim Ye, Mo, Da, Filename, SN, toaddress, ccaddress, bccaddress As String '変数設定：To宛先、cc宛先、bcc宛先
    Dim subject, mailBody, credit As String '変数設定：件名、メール本文、クレジット、添付
    Dim outlookObj As Outlook.Application    'Outlookで使用するオブジェクト生成
    Dim mailItemObj As Outlook.mailItem      'Outlookで使用するオブジェクト生成
    Dim i,SC As Long
      '---コード1｜outlookを起動する

'---コード2｜差出人、本文、署名を取得する---
    toaddress = "masaki@outloo.me"
    subject = Range("J5") & Year(Date) & Month(Date) & Day(Date) & "教育修了者の件"
    mailBody = Year(Date) & Month(Date) & Day(Date) & "の" & Range("J5") & "教育修了者です。" & vbCrLf & "確認してください。"
'---コード3｜メールを作成して、差出人、本文、署名を入れ込む---
    Set outlookObj = CreateObject("Outlook.Application")
    Set mailItemObj = outlookObj.CreateItem(olMailItem)
    mailItemObj.BodyFormat = 3      'リッチテキストに変更
    mailItemObj.To = toaddress      'to宛先をセット
    'mailItemObj.cc = ccaddress      'cc宛先をセット
   ' mailItemObj.BCC = bccaddress    'bcc宛先をセット
    mailItemObj.subject = subject   '件名をセット
    
'---コード4｜メール本文を改行する
    mailItemObj.Body = mailBody & vbCrLf & credit  'メール本文 改行 改行 クレジット
    
'---コード5｜自動で添付ファイルを付ける---
    Dim attached As String
    Dim myattachments As Outlook.Attachments 'Outlookで使用するオブジェクト生成
    Set myattachments = mailItemObj.Attachments
    attached = ThisWorkbook.Path & "\" & Filename & ".pdf"     '添付ファイル
    myattachments.Add attached

'---コード6｜メールを送信する---
    'mailItemObj.Save   '下書き保存
    'mailItemObj.Display  'メール表示(ここでは誤送信を防ぐために表示だけにして、メール送信はしない)
     mailItemObj.Send
     
'---コード7｜outlookを閉じる(オブジェクトの解放)---
    Set outlookObj = Nothing
    Set mailItemObj = Nothing

Sub yy()


Application.ScreenUpdating = False
SC = ActiveWorkbook.Sheets.Count
Ye = Year(Date) & "年"
Mo = Month(Date) & "月"
Da = Day(Date) & "日"
i = 1
Do While i <= SC


Worksheets(i).Copy


PrintCommunication = False

With ActiveSheet.PageSetup
.PrintArea = Range("A1:G29").Address
.Zoom = 80
.PaperSize = xlPaperA4
.CenterHorizontally = True
.CenterVertically = True
.LeftMargin = Application.CentimetersToPoints(0.8)
.RightMargin = Application.CentimetersToPoints(0.8)
End With
PrintCommunication = True
ActiveSheet.Name = Range("J5") & Year(Date) & Month(Date) & Day(Date)
Filename = Range("J5") & Ye & Mo & Da
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Filename & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Filename & ".xlsx"
ActiveWorkbook.Close


i = i + 1
Loop

Application.ScreenUpdating = True
End Sub


無事にシート名の変更までできました。
あとはメールの送信関係をまとめること、データを一つの一覧シートにまとめる作業になります。
先行してメール関係、添付ファイルをうまくできるようにしてから一覧の表作成に行きたいです



ようやく、メール処理のところまでできたのですが、これからは一覧表化に挑戦をしていきたいと思います。
とりあえずは、添付ファイルの処理も確認できたので出来高70ということにしておきたいです。
実践を考えるとまだ出来高は４０弱ですがこの休み中にやろうと思っていたことはほぼ終わりました。
これからはゆっくりと夏休みを満喫したいと思います。

Sub yy()


Dim Ye, Mo, Da, Filename, SN, toaddress, ccaddress, bccaddress As String
Dim subject, mailBody, credit As String '
Dim outlookObj As Outlook.Application
Dim mailItemObj As Outlook.mailItem
Dim i, SC As Long


Application.ScreenUpdating = False
SC = ActiveWorkbook.Sheets.Count
Ye = Year(Date) & "年"
Mo = Month(Date) & "月"
Da = Day(Date) & "日"
i = 1
Do While i <= SC


Worksheets(i).Copy


PrintCommunication = False

With ActiveSheet.PageSetup
.PrintArea = Range("A1:G29").Address
.Zoom = 80
.PaperSize = xlPaperA4
.CenterHorizontally = True
.CenterVertically = True
.LeftMargin = Application.CentimetersToPoints(0.8)
.RightMargin = Application.CentimetersToPoints(0.8)
End With
PrintCommunication = True
ActiveSheet.Name = Range("J5") & Year(Date) & Month(Date) & Day(Date)
Filename = Range("J5") & Ye & Mo & Da
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Filename & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Filename & ".xlsx"



toaddress = "masaki@shiina.me"
subject = Range("J5") & Year(Date) & Month(Date) & Day(Date) & "zzzzzzzzzzzzzzzz"
mailBody = Year(Date) & Month(Date) & Day(Date) & "の" & Range("J5") & "qqqqqqqqq" & vbCrLf & "sassa。"

Set outlookObj = CreateObject("Outlook.Application")
Set mailItemObj = outlookObj.CreateItem(olMailItem)
mailItemObj.BodyFormat = 3
mailItemObj.To = toaddress
mailItemObj.cc = ccaddress
mailItemObj.BCC = bccaddress
mailItemObj.subject = subject


mailItemObj.Body = mailBody & vbCrLf & credit


Dim attached As String
Dim myattachments As Outlook.Attachments
Set myattachments = mailItemObj.Attachments
attached = ThisWorkbook.Path & "\" & Filename & ".pdf"
myattachments.Add attached


mailItemObj.Save
mailItemObj.Display
mailItemObj.Send


Set outlookObj = Nothing
Set mailItemObj = Nothing
　　ActiveWorkbook.Close


i = i + 1
Loop

Application.ScreenUpdating = True
ActiveWorkbook.Close
End Sub

ちょっと解決まで時間がかかったけれど、現状実現したいことある程度できたのでよしとします。
それにしても転んで倒れて手が痛い。。。。

Sub 違うワークブック定型帳票データ複数行収集()
Dim fso As FileSystemObject
Dim MaxRow As Long
Set fso = New FileSystemObject
Dim pass As String
pass = ThisWorkbook.Path & "\zzzz"
Dim month As Date, department As String, fullname As String
Dim i As Long, j As Long
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
j = MaxRow + 1
Dim f As File
For Each f In fso.GetFolder(pass).Files
With Workbooks.Open(f)
With .Worksheets(1)


i = 18
Do While .Cells(i, 1).Value <> ""

Sheet1.Cells(j, 1).Value = .Cells(i, 1).Value
Sheet1.Cells(j, 2).Value = .Cells(i, 2).Value
Sheet1.Cells(j, 3).Value = .Cells(i, 3).Value
Sheet1.Cells(j, 4).Value = .Cells(i, 4).Value
Sheet1.Cells(j, 5).Value = .Cells(i, 5).Value
Sheet1.Cells(j, 6).Value = .Cells(i, 6).Value
i = i + 1
j = j + 1
Loop
End With
.Close
End With
Next f
End Sub

個人ごとですが、昨晩脚をつってしまいかなりいたい感じで今います。





Sub mail and Outlook()
Application.ScreenUpdating = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\xxxxxx\" + Range("AM2") & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    
    
  ActiveSheet.Copy


    
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = "$A$1:$AN$166"
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0.590551181102362)
        .BottomMargin = Application.InchesToPoints(0.196850393700787)
        .HeaderMargin = Application.InchesToPoints(0.393700787401575)
        .FooterMargin = Application.InchesToPoints(0.196850393700787)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA3
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True

ActiveSheet.Name = "yyyyy" & Range("AM2")
ActiveWorkbook.SaveAs Filename:="C:\xxxxxx\" + Range("AM2").Value _
        , FileFormat:=xlWorkbookDefault _
         , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
         CreateBackup:=False


Dim toaddress, ccaddress, bccaddress As String
Dim subject, mailBody, credit As String '
Dim outlookObj As Outlook.Application
Dim mailItemObj As Outlook.mailItem

Dim SavDir As String
Dim hidut As String


Application.ScreenUpdating = False
SavDir = "C:\xxxxxx\" 
hidut = Range("AM2")
         
toaddress = "eee.dddddd@serew.com"
subject = Range("B2")
mailBody = Range("B2") & "ooooooooo。" & vbCrLf & "qqqqqqqq"

Set outlookObj = CreateObject("Outlook.Application")
Set mailItemObj = outlookObj.CreateItem(olMailItem)
mailItemObj.BodyFormat = 3
mailItemObj.To = toaddress
mailItemObj.cc = ccaddress
mailItemObj.BCC = bccaddress
mailItemObj.subject = subject


mailItemObj.Body = mailBody & vbCrLf & credit


Dim attached, attached2 As String
Dim myattachments As Outlook.Attachments
Set myattachments = mailItemObj.Attachments
attached = SavDir & hidut & ".pdf"
attached2 = SavDir & hidut & ".xlsx"
myattachments.Add attached
myattachments.Add attached2


'mailItemObj.Save
mailItemObj.Display
'mailItemObj.Send


Set outlookObj = Nothing
Set mailItemObj = Nothing
    ActiveWorkbook.Close

Kill SavDir & hidut & ".pdf"

Kill SavDir & hidut & ".xlsx"

Application.ScreenUpdating = True
ActiveWorkbook.Close
End Sub

単票からリスト化する作業ができそうです。
Offsetを使う予定ではなかったけれどこれが使いやすかったのでまぁ良しとしたいところです。贅沢は敵ですしね。。。
次の予定はもう決めてありますけれど、うまくできるかは定かではない。。。。

  Sub yy()


    Dim Ye, Mo, Da, Filename, SN, toaddress, ccaddress, bccaddress As String
    Dim subject, mailBody, credit As String '
    Dim outlookObj As Outlook.Application
    Dim mailItemObj As Outlook.mailItem
    Dim i, SC As Long
    
    
Application.ScreenUpdating = False
SC = ActiveWorkbook.Sheets.Count

i = 1
Do While i <= SC
'Do While i <= 5

Worksheets(i).Copy

Ye = Year(Range("E1")) & "年"
Mo = Month(Range("E1")) & "月"
Da = Day(Range("E1")) & "日"
Filename = Range("B1") & Ye & Mo & Da
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\xxxx\" & Filename & ".xlsx"

PrintCommunication = False

With ActiveSheet.PageSetup
.PrintArea = Range("B2:Q52").Address
.Zoom = 90
.PaperSize = xlPaperA4
.CenterHorizontally = True
.CenterVertically = True
.LeftMargin = Application.CentimetersToPoints(0.8)
.RightMargin = Application.CentimetersToPoints(0.8)
End With
PrintCommunication = True

ActiveSheet.Name = Range("B1") & Year(Range("E1")) & Month(Range("E1")) & Day(Range("E1"))
Dim days As Date
Dim DayCon, dedura1, dedura2, dedura3, dedura4, dedura5, dedura6, dedura7, dedura8, dedura9 As Long
Dim fullname, sagyo1, sagyo2, sagyo3, sagyo4, sagyo5 As String
            
            With ActiveSheet
            
            days = .Range("E1").Value
            DayCon = .Range("M6").Value
            fullname = .Range("E7").Value
             dedura1 = .Range("M9").Value
             dedura2 = .Range("M10").Value
             dedura3 = .Range("M11").Value
             dedura4 = .Range("M12").Value
             dedura5 = .Range("M13").Value
             dedura6 = .Range("M14").Value
             dedura7 = .Range("M15").Value
             dedura8 = .Range("M16").Value
             dedura9 = .Range("M17").Value
             sagyo1 = .Range("E19").Value
             sagyo2 = .Range("E20").Value
             sagyo3 = .Range("E21").Value
             sagyo4 = .Range("E22").Value
             sagyo5 = .Range("E23").Value
             
End With
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks.Open ThisWorkbook.Path & "\リスト.xlsx"
ActiveSheet.Range("A1").Select
    With Cells(Rows.Count, 1).End(xlUp)
        .Offset(1, 0) = days
        .Offset(1, 1) = DayCon
        .Offset(1, 2) = fullname
        .Offset(1, 3) = dedura1
        .Offset(1, 4) = dedura2
        .Offset(1, 5) = dedura3
        .Offset(1, 6) = dedura4
        .Offset(1, 7) = dedura5
        .Offset(1, 8) = dedura6
        .Offset(1, 9) = dedura7
        .Offset(1, 10) = dedura8
        .Offset(1, 11) = dedura9
        .Offset(1, 12) = sagyo1
        .Offset(1, 13) = sagyo2
        .Offset(1, 14) = sagyo3
        .Offset(1, 15) = sagyo4
        .Offset(1, 16) = sagyo5
    End With

ActiveWorkbook.Save
ActiveWorkbook.Close


i = i + 1
Loop

Application.ScreenUpdating = True
ActiveWorkbook.Close
End Sub

このぐらいのことしかやっていない。
Sub 収集()
Dim fso As FileSystemObject
Dim MaxRow As Long
Set fso = New FileSystemObject
Dim pass As String
pass = ThisWorkbook.Path & "\テスト"
Dim month As Date, department As String, fullname As String
Dim i As Long, j As Long 
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
j = MaxRow + 1
Dim f As File
For Each f In fso.GetFolder(pass).Files
    With Workbooks.Open(f)
        With .Worksheets(1)

            i = 18
            Do While .Cells(i, 1).Value <> ""
                
                Sheet1.Cells(j, 1).Value = .Cells(i, 1).Value
                Sheet1.Cells(j, 2).Value = .Cells(i, 2).Value
                Sheet1.Cells(j, 3).Value = .Cells(i, 3).Value
                Sheet1.Cells(j, 4).Value = .Cells(i, 4).Value
                Sheet1.Cells(j, 5).Value = .Cells(i, 5).Value
                Sheet1.Cells(j, 6).Value = .Cells(i, 6).Value
                i = i + 1
                j = j + 1
            Loop
        End With
        .Close
    End With
Next f
End Sub

り量を減らして）

ちょっと手直しといった感じですね

基本形は変わっていません。
ただ簡易版といったところですね。
Dimのところに今回は入れていないものが入っているところからも分かるようにメール送信機能を削除しています。



  Sub yy()


    Dim Ye, Mo, Da, Filename, SN, toaddress, ccaddress, bccaddress As String
    Dim subject, mailBody, credit As String '
    Dim outlookObj As Outlook.Application
    Dim mailItemObj As Outlook.mailItem
    Dim i, SC As Long
    
    
Application.ScreenUpdating = False
SC = ActiveWorkbook.Sheets.Count

i = 1
Do While i <= SC


Worksheets(i).Copy

Ye = Year(Range("E1")) & "年"
Mo = Month(Range("E1")) & "月"
Da = Day(Range("E1")) & "日"
Filename = Range("B1") & Ye & Mo & Da
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Excelファイル\" & Filename & ".xlsx"

PrintCommunication = False

With ActiveSheet.PageSetup
.PrintArea = Range("B2:Q52").Address
.Zoom = 90
.PaperSize = xlPaperA4
.CenterHorizontally = True
.CenterVertically = True
.LeftMargin = Application.CentimetersToPoints(0.8)
.RightMargin = Application.CentimetersToPoints(0.8)
End With
PrintCommunication = True

ActiveSheet.Name = Range("B1") & Year(Range("E1")) & Month(Range("E1")) & Day(Range("E1"))
ActiveWorkbook.Save




ActiveWorkbook.Close


i = i + 1
Loop

Application.ScreenUpdating = True
ActiveWorkbook.Close
End Sub

コメント

コメントを投稿

このブログの人気の投稿

エクセルマクロをすこし 2018年8月25日 リストから別のリストを作成

リストからさらにリスト作成ということで特にどう繰り返すかがなかなか思いつかなかった。 また、苦労した点は1列目の選択方法と必要な列の数えるところです。 思った通りにはなかなかならず、いろいろな方面から攻めてやっと結果が出たような気がします。これからの展開はカレンダー（Outlookで）の登録です。こちらはVBAを使うか否か、Outlookの機能そのままにしようか迷っています。 数が少ない場合りすとかする過程の中で取り込めて行ける方向で処理ができればと思います。 Googleカレンダーへの登録についてはすでに自分の中で方法が確立しできているのでここには載せないです。 Sub リストから別のリスト作成() Dim da1 As Date Dim sagyou1,  As String Dim i, j, RX, ConC As Long`この辺りはお好みになりそうです Dim FN As String Application.ScreenUpdating = False Range("A1").Select CR = Cells(Rows.Count, 1).End(xlUp).Row i = 2`1行目はタイトル行の為2行目からの処理ということで Do While i <= CR   ' Cells(i+1, 0).Value With Cells(Rows.Count, 1).End(xlUp)   End With da1 = ActiveSheet.Range("A" & CStr(i)).Value j = 1 ConC = WorksheetFunction.CountA(Range(Cells(i, 13), Cells(i, 18))) - 1`この行の処理はちょっと代替手段を考えたい                 Do While j <= ConC                 sagyo1 = Ac...
続きを読む