[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『質問はのちほどUPします。』（GREEN）
質問は後程まとめます。
'＊＊＊＊＊仕入先毎にFORECASTBOOKを作成する＊＊＊＊＊＊＊＊＊
Dim k As Long
FC1.Select
'FORECAST SUMMARYの4行目から最終行まで For i = 4 To ROWSFC1
'もし仕入先名が１行上の仕入先名とちがったら
If FC1.Cells(i, 1).Value <> FC1.Cells(i - 1, 1).Value Then
'新しいBOOKをひらく
Dim WBNEW As Workbook, ws As Worksheet
Set WBNEW = Workbooks.Add
Set ws = WBNEW.Worksheets(1)
'タイトル行コピー
WB.Activate
FC1.Select
Range(Cells(2, 2), Cells(3, LC1)).Copy
WBNEW.Activate
ws.Select
Range("A8").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
'Kを10とする
k = 10
ws.Cells(k, 1).Value = FC1.Cells(i, 2).Value 'PART NO
ws.Cells(k, 2).Value = FC1.Cells(i, 3).Value 'PART NAME またはメーカー品番
ws.Cells(k, 3).Value = FC1.Cells(i, 4).Value 'LEAD TIME
ws.Cells(k, 4).Value = FC1.Cells(i, 5).Value 'MOQ
ws.Cells(k, 5).Value = FC1.Cells(i, 6).Value 'MPQ
ws.Cells(k, 6).Value = FC1.Cells(i, 7).Value 'CUSTOMER
'FORECAST数量コピー貼り付け
FC1.Activate
FC1.Select
FC1.Range(Cells(i, 8), Cells(i, LC1)).Copy
WBNEW.Activate
ws.Select
ws.Cells(k, 7).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
k = k + 1
'FORECAST SUMMARYのi行プラス1行から最終行まで
For x = i + 1 To ROWSFC1
If FC1.Cells(x, 1).Value = FC1.Cells(i, 1).Value Then
ws.Cells(k, 1).Value = FC1.Cells(x, 2).Value 'PART NO
ws.Cells(k, 2).Value = FC1.Cells(x, 3).Value 'PART NAME またはメーカー品番
ws.Cells(k, 3).Value = FC1.Cells(x, 4).Value 'LEAD TIME
ws.Cells(k, 4).Value = FC1.Cells(x, 5).Value 'MOQ
ws.Cells(k, 5).Value = FC1.Cells(x, 6).Value 'MPQ
ws.Cells(k, 6).Value = FC1.Cells(x, 7).Value 'CUSTOMER
'FORECAST数量コピー貼り付け
FC1.Activate
FC1.Select
FC1.Range(Cells(x, 8), Cells(x, LC1)).Copy
WBNEW.Activate
ws.Select
ws.Cells(k, 7).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
k = k + 1
Else
End If
Next x
'仕入先毎のBOOK加工
Dim Supplier As String
Supplier = FC1.Cells(i, 1).Value
ws.Range("A1").Value = Supplier & "様"
ws.Range("A3").Value = "いつもお世話になり有難うございます。"
ws.Range("A4").Value = "カッティング機用部材 発注予測数量をご連絡させて頂きます。"
ws.Range("A5").Value = "こちらの数量は予測数量であり、変更になる可能性がございます。"
ws.Range("A6").Value = "ご了承頂けますようお願いいたします。"
ws.Range("A8").Value = "品番"
ws.Range("B8").Value = "品名" & vbLf & "メーカー品番"
ws.Range("F8").Value = "向け地"
ws.Range("G8").Value = "発注予測数量"
'仕入先毎BOOKの最終列・最終行取得
'最終列の宣言
Dim LC2 As Long
LC2 = ws.Range("G9").End(xlToRight).Column
'最終行の宣言
Dim LR2 As Long
LR2 = FC.Cells(Rows.Count, 1).End(xlUp).Row
ws.Cells(1, LC2).Value = Date
ws.Cells(2, LC2).Value = MCR.Range("E42").Value
ws.Cells(3, LC2).Value = MCR.Range("E44").Value
'MOQ MPQ数量にコンマ入れる
Range(Cells(10, 3), Cells(LR2, 5)).NumberFormat = "#,###"
'表 書式の設定
With Range("A8").CurrentRegion
.Borders.LineStyle = True '枠線を入れる
.BorderAround Weight:=xlMedium, LineStyle:=xlContinuous
.Font.Name = "Arial Unicode MS" 'フォント指定
End With
'二重線入れる
Range(Cells(10, 1), Cells(10, LC2)).Borders(xlEdgeTop).LineStyle = xlDouble
'列幅の設定
Columns(1).ColumnWidth = 26 'PARTNO
Columns(2).ColumnWidth = 26 '品名/ﾒｰｶｰ品番
Range(Columns(3), Columns(5)).ColumnWidth = 8.5 'LEAD TIME MOQ MPQ
Columns(6).ColumnWidth = 11 '向け地
Range(Columns(7), Columns(LC2)).ColumnWidth = 13
'文字左詰め 中央 右詰め
Range(Columns(1), Columns(2)).HorizontalAlignment = xlLeft
Range(Columns(3), Columns(LC2)).HorizontalAlignment = xlCenter
Range("A8").HorizontalAlignment = xlCenter
Range("A9").HorizontalAlignment = xlCenter
Range(Cells(1, LC2), Cells(3, LC2)).HorizontalAlignment = xlRight
'1,2,6列目縮小して表示
Range(Cells(10, 1), Cells(LR2, 1)).ShrinkToFit = True
Columns(2).ShrinkToFit = True
Columns(6).ShrinkToFit = True
'フォント指定
ActiveSheet.Cells.Font.Name = "Arial Unicode MS"
'A1選択
Range("A1").Select
'ページ設定
With ws.PageSetup
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
.CenterHorizontally = True
.Orientation = xlLandscape
End With
'ファイル名を生成して保存して閉じる
Dim fileName As String
fileName = WB.Path & "\" & Format(Date, "yyyymmdd") & "_FORECAST_" & Supplier & "様" & ".xlsx"
WBNEW.SaveAs fileName
WBNEW.Close
Else '仕入先名が一行上の仕入先名と同じだったらなにもしない
End If
Next i
End Sub
'**MAIL シート加工***
Mail.Activate
Range("A1").Value = "仕入先"
Range("B1").Value = "発注"
Range("C1").Value = "FORECAST"
'発注あり仕入先 入力
x = 2
For i = 3 To LRORDER
Cells(x, 1).Value = ORDER.Cells(i, 7).Value
Cells(x, 2).Value = 1
x = x + 1
Next i
'FORECASTあり仕入先 入力
'MAILシートの最終行取得
LRMAIL = Mail.Cells(Rows.Count, 1).End(xlUp).Row
x = LRMAIL + 1
For i = 3 To LRFC
Cells(x, 1).Value = FORECAST.Cells(i, 7).Value
Cells(x, 3).Value = 1
x = x + 1
Next i
'重複削除
'MAILシートの最終行取得
LRMAIL = Mail.Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:C" & LRMAIL).RemoveDuplicates (Array(1, 2, 3))
'MAILシートの最終行取得 削除後の最終行
LRMAIL = Mail.Cells(Rows.Count, 1).End(xlUp).Row
'*****ピポットテーブル作成***** Dim pvt As PivotTable Dim rngData As Range
'元データを変数に格納 Set rngData = Mail.Range(Cells(1, 1), Cells(LRMAIL, 3))
'ピボットテーブルの設定
Set pvt = _
ActiveWorkbook.PivotCaches.Add( _
SourceType:=xlDatabase, _
SourceData:=rngData). _
CreatePivotTable(TableDestination:=Range("F1"))
' フィールドの配置
With pvt
' 行フィールド指定
.PivotFields("仕入先").Orientation = xlRowField
.PivotFields("仕入先").Position = 1
'データフィールドの設定
.AddDataField .PivotFields("発注"), "合計 / 発注", xlSum
.AddDataField .PivotFields("FORECAST"), "合計 / FORECAST", xlSum
.DataPivotField.Orientation = xlColumnField
.InGridDropZones = True
.RowAxisLayout xlTabularRow '表形式にする
End With
'ピポッドコピー値貼り付け
Mail.Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
'*****ピポットテーブル作成終了*****
Range("I2").Value = "仕入先名"
Range("J2").Value = "担当者名"
Range("K2").Value = "TO"
Range("L2").Value = "CC"
Range("M2").Value = "担当CC"
Range("N2").Value = "CC結合"
'ピポッドのSHEET MAIL最終行取得
LRMAIL = Mail.Cells(Rows.Count, 6).End(xlUp).Row - 1
'SHEET名：発注用メールリスト
''メール発注用LIST OPEN
Workbooks.Open fileName:=Worksheets("MACRO").Range("B91")
Application.DisplayAlerts = False
''WBMAILLIST set as WORKBOOK of 発注用メールリスト
Dim WBMAILLIST As Workbook
Set WBMAILLIST = ActiveWorkbook
'WSMAILLIST set as worksheets of 発注用メールリスト
Dim WSMAILLIST As Worksheet
Set WSMAILLIST = WBMAILLIST.Worksheets("発注用メールリスト")
'NO AUTOFILTER
WSMAILLIST.AutoFilterMode = False
Dim LRWSMAILLIST As Long
LRWSMAILLIST = WSMAILLIST.Cells(Rows.Count, 1).End(xlUp).Row
'select worksheets of "ORDER"
WB.Activate
Mail.Activate
'RING仕入先名 追記
For i = 3 To LRMAIL
For x = 2 To LRWSMAILLIST
If Mail.Cells(i, 6).Value = WSMAILLIST.Cells(x, 2).Value Then
'仕入先名
Mail.Cells(i, 9).Value = WSMAILLIST.Cells(x, 1).Value
'担当者名
Mail.Cells(i, 10).Value = WSMAILLIST.Cells(x, 3).Value
'TO
Mail.Cells(i, 11).Value = WSMAILLIST.Cells(x, 4).Value
'CC
Mail.Cells(i, 12).Value = WSMAILLIST.Cells(x, 5).Value
'担当CC
Mail.Cells(i, 13).Value = WSMAILLIST.Cells(x, 6).Value
Else
End If
Next x
Next i
'仕入先名がないものエラーメッセージでマクロおわる
'Dim Supplier As Variant
For i = 3 To LRMAIL
If Mail.Cells(i, 9).Value = "" Then
Supplier = Mail.Cells(i, 6).Value
MsgBox Supplier & "の仕入先名がありません。"
MsgBox "発注用メールリストを更新してもう一度( ｀ー´)ノ"
Exit Sub
Else
End If
Next i
'CC結合作成
For i = 3 To LRMAIL
If Mail.Cells(i, 12).Value = "" Then
Mail.Cells(i, 14).Value = Mail.Cells(i, 13).Value
Else
Mail.Cells(i, 14).Value = Mail.Cells(i, 12).Value & ";" & Mail.Cells(i, 13).Value
End If
Next i
Columns("A:N").AutoFit
WBMAILLIST.Close
'********OUTLOOKMAIL作成********
'Dim Outlook As Outlook.Application
Set Outlook = New Outlook.Application
'Dim NewMail As Outlook.MailItem
'
'Dim TANTOU As Variant
'メールを作成する
For i = 3 To LRMAIL
Supplier = Mail.Cells(i, 9).Value
TANTOU = Mail.Cells(i, 10).Value
If Cells(i, 7) = 1 And Cells(i, 8) = 1 Then
Call HACCHUFORECASTMAIL '発注とFORECASTがある場合”
ElseIf Cells(i, 7) = 1 And Cells(i, 8) = "" Then
Call HACCHUMAIL '発注だけの場合
ElseIf Cells(i, 7) = "" And Cells(i, 8) = 1 Then
Call FORECASTMAIL 'FORECASTだけの場合
Else
End If
Next i
MsgBox "メールを" & LRMAIL - 2 & "件保存しました。(*'▽')"
Set Outlook = Nothing
'本文
'タブ色変更
Worksheets("MAIL").Delete
End Sub
Sub HACCHUMAIL() '発注だけのときのMAIL
Dim MACRO As Worksheet
Set MACRO = Worksheets("MACRO")
Set NewMail = Outlook.CreateItem(olMailItem)
With NewMail
'メール宛先
.To = Cells(i, 11).Value
.CC = Cells(i, 14).Value
'メール件名
.Subject = "【" & Cells(i, 6) & "様】新規注文書_" & Format(Date, "yyyy/mm/dd")
'メールの形式
.BodyFormat = olFormatHTML
'メール本文
.Body = Supplier & vbLf & TANTOU & vbLf & vbLf & "いつもお世話になっております。" & vbLf & _
"商事??" & MACRO.Range("E42") & "です。" & vbLf & _
vbLf & _
"早速ではございますが添付にて新規発注書をお送り致します｡" & vbLf & _
"今回FORECAST情報はございません。" & vbLf & _
vbLf & _
"注文NO" & vbLf & _
vbLf & _
vbLf & _
vbLf & _
"恐れ入りますが､添付発注書受領後3営業日以内に納期回答を" & vbLf & _
"メールもしくはFAXにてご返答頂きますようお願い致します｡" & vbLf & _
"お手数おかけいたしますが" & vbLf & _
"ご確認何卒宜しくお願いいたします。" & vbLf & vbLf & _
"商事株式会社" & vbLf & _
"営業" & vbLf & _
MACRO.Range("E42")
End With
NewMail.Save 'NewMail.Send
End Sub
Sub FORECASTMAIL() 'FORECASTだけのときのMAIL
Dim MACRO As Worksheet
Set MACRO = Worksheets("MACRO")
Set NewMail = Outlook.CreateItem(olMailItem)
With NewMail
'メール宛先
.To = Cells(i, 11).Value
.CC = Cells(i, 14).Value
'メール件名
.Subject = "【" & Cells(i, 6) & "様】FORECAST情報_" & Format(Date, "yyyy/mm/dd")
'メールの形式
.BodyFormat = olFormatHTML
'メール本文
.Body = Supplier & vbLf & TANTOU & vbLf & vbLf & "いつもお世話になっております。" & vbLf & _
"商事??" & MACRO.Range("E42") & "です。" & vbLf & _
vbLf & _
"早速ではございますが添付にてFORECAST情報を送付致します｡" & vbLf & _
"今回新規注文はございません。" & vbLf & _
"お手数おかけいたしますが" & vbLf & _
"ご確認何卒宜しくお願いいたします。" & vbLf & vbLf & _
"商事株式会社" & vbLf & _
"１部" & vbLf & _
MACRO.Range("E42")
End With
NewMail.Save 'NewMail.Send
End Sub
Sub HACCHUFORECASTMAIL() '発注とFORECASTのときのMAIL
Dim MACRO As Worksheet
Set MACRO = Worksheets("MACRO")
Set NewMail = Outlook.CreateItem(olMailItem)
With NewMail
'メール宛先
.To = Cells(i, 11).Value
.CC = Cells(i, 14).Value
'メール件名
.Subject = "【" & Cells(i, 6) & "様】新規注文＆FORECAST情報_" & Format(Date, "yyyy/mm/dd")
'メールの形式
.BodyFormat = olFormatHTML
'メール本文
.Body = Supplier & vbLf & TANTOU & vbLf & vbLf & "いつもお世話になっております。" & vbLf & _
"商事??" & MACRO.Range("E42") & "です。" & vbLf & _
vbLf & _
"早速ではございますが添付にて新規発注書と今後の所要情報をお送り致します｡" & vbLf & _
vbLf & _
"注文NO" & vbLf & _
vbLf & _
vbLf & _
vbLf & _
"恐れ入りますが､添付発注書受領後3営業日以内に納期回答を" & vbLf & _
"メールもしくはFAXにてご返答頂きますようお願い致します｡" & vbLf & _
"お手数おかけいたしますが" & vbLf & _
"ご確認何卒宜しくお願いいたします。" & vbLf & vbLf & _
"商事株式会社" & vbLf & _
"１部(7F)" & vbLf & _
MACRO.Range("E42")
End With
NewMail.Save 'NewMail.Send
End Sub
Attribute VB_Name = "グループ毎にBOOKを作る"
Option Explicit
Sub グループ毎にBOOKをつくる()
Dim MacroB As Worksheet 'このブックのシート
Dim Wb_Data As Workbook '1. 分割元ブック
Dim Wb_new As Workbook '分割データ保存ブック
Dim Ws As String '2. 分割元シート名
Dim Path As String '3. 分割データ保存先
Dim GroupName As String 'グループ名（ブック名）
Dim C_Copy As Long '5. コピーデータ右端列
Dim MOTOWB As Workbook '元データBOOKをMOTOWBとする
Dim R_Data As Integer 'データの行番号
Dim Ko As Integer 'グループの件数
Dim HOZONNAME As String 'ブック保存名
Set MacroB = ThisWorkbook.Worksheets("グループ別BOOK作成") 'このブックのシート
Set MOTOWB = Workbooks.Open(MacroB.Range("C11").Value) '元データBOOKをMOTOWBとする
Ws = MacroB.Range("C12") '分割元シート名
Path = MacroB.Range("C13") & "\" '分割データ保存先
C_Copy = MOTOWB.Worksheets(Ws).Cells(1, Columns.Count).End(xlToLeft).Column 'コピーデータ右端列
HOZONNAME = MacroB.Range("C20").Value '保存BOOK名
R_Data = 2 'データの開始行
Application.ScreenUpdating = False
'元データ並び替え
'現在の並べ替え解除 MOTOWB.Worksheets(Ws).Activate Worksheets(Ws).Sort.SortFields.CLEAR
'SORT KEY1の列数
Dim KEY1 As Long
KEY1 = Worksheets(Ws).Rows(1).Find(MacroB.Range("C16"), LookAt:=xlPart).Column
If KEY1 = 0 And MacroB.Range("C16").Value <> "" Then
MsgBox "タイトル行に" & MacroB.Range("C16").Value & "がみつかりません。"
MsgBox "SORT KEY1を確認してください。"
Exit Sub
Else
End If
'SORT KEY2の列数
Dim KEY2 As Long
If MacroB.Range("C17") <> "" Then
KEY2 = Worksheets(Ws).Rows(1).Find(MacroB.Range("C17"), LookAt:=xlPart).Column
ElseIf KEY1 = 0 And MacroB.Range("C17").Value <> "" Then
MsgBox "タイトル行に" & MacroB.Range("C17").Value & "がみつかりません。"
MsgBox "SORT KEY2を確認してください。"
Exit Sub
Else
End If
'SORT KEY3の列数
Dim KEY3 As Long
If MacroB.Range("C18") <> "" Then
KEY3 = Worksheets(Ws).Rows(1).Find(MacroB.Range("C18"), LookAt:=xlPart).Column
ElseIf KEY3 = 0 And MacroB.Range("C18").Value <> "" Then
MsgBox "タイトル行に" & MacroB.Range("C18").Value & "がみつかりません。"
MsgBox "SORT KEY3を確認してください。"
Exit Sub
Else
End If
'SORT KEY4の列数
Dim KEY4 As Long
If MacroB.Range("C19") <> "" Then
KEY4 = Worksheets(Ws).Rows(1).Find(MacroB.Range("C19"), LookAt:=xlPart).Column
ElseIf KEY4 = 0 And MacroB.Range("C19").Value <> "" Then
MsgBox "タイトル行に" & MacroB.Range("C19").Value & "がみつかりません。"
MsgBox "SORT KEY4を確認してください。"
Exit Sub
Else
End If
'もしソートKEY２，３，４がなしだったら
If KEY2 = 0 And KEY3 = 0 And KEY4 = 0 Then
Call Worksheets(Ws).Range("A1").CurrentRegion.Sort( _
KEY1:=Worksheets(Ws).Cells(1, KEY1), _
Order1:=xlAscending, _
Header:=xlYes)
'もしソートKEY３ ４がなしだったら ElseIf KEY3 = 0 And KEY4 = 0 Then
Call Worksheets(Ws).Range("A1").CurrentRegion.Sort( _
KEY1:=Worksheets(Ws).Cells(1, KEY1), _
Order1:=xlAscending, _
KEY2:=Worksheets(Ws).Cells(1, KEY2), _
Order2:=xlAscending, _
Header:=xlYes)
'もしソートKEY４がなしだったら ElseIf KEY4 = 0 Then
Call Worksheets(Ws).Range("A1").CurrentRegion.Sort( _
KEY1:=Worksheets(Ws).Cells(1, KEY1), _
Order1:=xlAscending, _
KEY2:=Worksheets(Ws).Cells(1, KEY2), _
Order2:=xlAscending, _
KEY3:=Worksheets(Ws).Cells(1, KEY3), _
Order3:=xlAscending, _
Header:=xlYes)
Else 'SORT KEY1,2,3,4すべてはいっているパターン
Call Worksheets(Ws).Range("A1").CurrentRegion.Sort( _
KEY1:=Worksheets(Ws).Cells(1, KEY1), _
Order1:=xlAscending, _
KEY2:=Worksheets(Ws).Cells(1, KEY2), _
Order2:=xlAscending, _
KEY3:=Worksheets(Ws).Cells(1, KEY3), _
Order3:=xlAscending, _
KEY4:=Worksheets(Ws).Cells(1, KEY4), _
Order4:=xlAscending, _
Header:=xlYes)
End If
Do
MOTOWB.Activate '分割元BOOK ACTIVATE
Worksheets(Ws).Range(Cells(1, 1), Cells(1, C_Copy)).Copy '1行目の項目名コピー
Workbooks.Add 'ワークブック作成
ActiveSheet.Paste Range("A1") '新規ブックに貼り付け
Set Wb_new = ActiveWorkbook
MOTOWB.Activate '分割元BOOK ACTIVATE
GroupName = Cells(R_Data, KEY1)
Ko = WorksheetFunction.CountIf(Columns(KEY1), GroupName) 'グループの件数を算出
Range(Cells(R_Data, "A"), Cells(R_Data + Ko - 1, C_Copy)).Copy 'グループ件数分コピー
Wb_new.Activate
ActiveSheet.Paste Range("A2") '新規ブック項目の下に貼り付け
If MacroB.Range("C21").Value = "1" Then
Wb_new.SaveAs filename:=Path & HOZONNAME & "_" & GroupName & "様_" & Format(Date, "yyyymmdd") & ".xlsx" '指定したフォルダーに保存
ElseIf Worksheets(Ws).Range("C21").Value = "2" Then
Wb_new.SaveAs filename:=Path & HOZONNAME & "_" & GroupName & "_" & Format(Date, "yyyymmdd") & ".xlsx" '指定したフォルダーに保存
Else
End If
'枠線をひく
With Wb_new.Worksheets("Sheet1")
'文字設定
.Cells.Font.Name = "Yu Gothic Medium"
'列幅調整
.Columns("A:Z").AutoFit
.Columns("E").ColumnWidth = 13
.Columns("F").ColumnWidth = 10
End With
'枠線をひく
If MacroB.Range("C22") = "1" Then
Wb_new.Worksheets("Sheet1").Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
Else
End If
Wb_new.Close Savechanges:=True '上書き保存して閉じる
R_Data = R_Data + Ko
Loop While Cells(R_Data, KEY1) <> ""
MsgBox "完了しました(*^^*)"
Application.ScreenUpdating = True
End Sub
Attribute VB_Name = "メール作成R01"
Option Explicit
Sub メール作成R01()
Dim i As Long
Dim x As Long
Dim SUPPLIER
Dim MAIL As Worksheet
Dim RENRAKU As Worksheet
Dim HONBUN As Worksheet
Dim LRM As Long
Dim Outlook As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim TANTOU As Variant
Dim attached As String
Dim mailItemObj As Outlook.MailItem
Dim attachObj As Outlook.Attachments
Dim Keyword As String
Set MAIL = Worksheets("MAIL")
Set RENRAKU = Worksheets("連絡先")
Set HONBUN = Worksheets("本文")
MAIL.AutoFilterMode = False
'MAILの最終行数をLRMとする
LRM = MAIL.Cells(Rows.Count, 1).End(xlUp).Row
'RENRAKUの最終行数をLRRとする
Dim LRR As Long
LRR = RENRAKU.Cells(Rows.Count, 1).End(xlUp).Row
RENRAKU.AutoFilterMode = False
'********OUTLOOKMAIL作成********
Set Outlook = New Outlook.Application
'
'メールを作成する
'MAILの15行目から最終行まで
For i = 15 To LRM
'メールアイテムオブジェクト作成
Set mailItemObj = Outlook.CreateItem(olMailItem)
'添付ファイルオブジェクト作成
Set attachObj = mailItemObj.Attachments
With mailItemObj
SUPPLIER = MAIL.Cells(i, 1).Value
For x = 3 To LRR 'RENRAKUの最終行数をLRRとする
'担当者名
'B11=規格化してますか？の質問
'IF 規格化していない
If MAIL.Range("B11").Value <> "YES" And SUPPLIER = RENRAKU.Cells(x, 1) And RENRAKU.Cells(x, 3).Value = "TO" Then
TANTOU = RENRAKU.Cells(x, 4)
'規格化している
ElseIf MAIL.Range("B11").Value = "YES" And SUPPLIER = RENRAKU.Cells(x, 2) And RENRAKU.Cells(x, 3).Value = "TO" Then
TANTOU = RENRAKU.Cells(x, 4)
End If
'メール宛先TO
'規格化していない
If MAIL.Range("B11").Value <> "YES" And SUPPLIER = RENRAKU.Cells(x, 1) And RENRAKU.Cells(x, 3).Value = "TO" Then
.To = RENRAKU.Cells(x, 5)
'規格化している
ElseIf MAIL.Range("B11").Value = "YES" And SUPPLIER = RENRAKU.Cells(x, 2) And RENRAKU.Cells(x, 3).Value = "TO" Then
.To = RENRAKU.Cells(x, 5)
End If
'メール宛先CC
'規格化していない
If MAIL.Range("B11").Value <> "YES" And SUPPLIER = RENRAKU.Cells(x, 1) And RENRAKU.Cells(x, 3).Value <> "CC" Then
.CC = MAIL.Range("B2").Value
'規格化していない
ElseIf MAIL.Range("B11").Value <> "YES" And SUPPLIER = RENRAKU.Cells(x, 1) And RENRAKU.Cells(x, 3).Value = "CC" Then
.CC = RENRAKU.Cells(x, 5) & ";" & MAIL.Range("B2").Value
'規格化している
ElseIf MAIL.Range("B11").Value = "YES" And SUPPLIER = RENRAKU.Cells(x, 2) And RENRAKU.Cells(x, 3).Value <> "CC" Then
.CC = MAIL.Range("B2").Value
'規格化している
ElseIf MAIL.Range("B11").Value = "YES" And SUPPLIER = RENRAKU.Cells(x, 2) And RENRAKU.Cells(x, 3).Value = "CC" Then
.CC = RENRAKU.Cells(x, 5) & ";" & MAIL.Range("B2").Value
Else
End If
Next x
'メール件名
If MAIL.Range("B12").Value = "NO" And MAIL.Range("B13").Value = "NO" Then
.Subject = MAIL.Range("B3").Value
ElseIf MAIL.Range("B12").Value = "YES" And MAIL.Range("B13").Value = "NO" Then
.Subject = MAIL.Range("B3").Value & "_" & Format(Date, "yyyy/mm/dd")
ElseIf MAIL.Range("B12").Value = "NO" And MAIL.Range("B13").Value = "YES" Then
.Subject = "【" & SUPPLIER & "様】 " & MAIL.Range("B3").Value
ElseIf MAIL.Range("B12").Value = "YES" And MAIL.Range("B13").Value = "YES" Then
.Subject = "【" & SUPPLIER & "様】 " & MAIL.Range("B3").Value & "_" & Format(Date, "yyyy/mm/dd")
Else
End If
'メールの形式
.BodyFormat = olFormatHTML
'メール本文
'
.Body = SUPPLIER & vbLf & _
TANTOU & "様" & vbLf & _
HONBUN.Cells(1, 1).Value
'メールアイテムにファイルを添付する
Keyword = SUPPLIER ' KEYWORDはSUPPLIER
'Sheet MAIL のB４が空白じゃなかったら ＝仕入先毎のファイルを添付する場合
If MAIL.Range("B4") <> "" Then
Call FileAttach(attachObj, Keyword)
Else
End If
'Sheet MAIL のB４が空白のとき ＝どの宛先にも同じファイルを添付する場合
Dim Z As Long
For Z = 5 To 10
If MAIL.Cells(Z, 2).Value <> "" Then
.Attachments.Add MAIL.Cells(Z, 2).Value, olByValue, 1, ""
Else
End If
Next Z
End With
mailItemObj.Save '下書きで保存
'NewMail.Send ’送るときはこれ
TANTOU = ""
Set SUPPLIER = Nothing
Next i
' mailItemObj.Display
MsgBox "メールを" & LRM - 14 & "件保存しました。(*'▽')"
Set Outlook = Nothing
End Sub
' 【機能】下書きメールアイテムにファイルを添付する ' 複数ファイル添付可能（キーワードを含むファイルをすべて添付する） ' キーワードを含むファイルが見つからない場合、何も添付しない
Sub FileAttach(attachObj As Object, Keyword As String)
Dim MAIL As Worksheet
Dim fileStorePath As String 'ファイル格納パス
Dim filename As String
Set MAIL = Worksheets("MAIL")
fileStorePath = MAIL.Range("B4") & "\"
filename = Dir(fileStorePath & "*")
'フォルダ内のファイル数、検索を繰り返す
Do While filename <> ""
'キーワードを含むファイルが見つかったら、下書きアイテムに添付する
If InStr(filename, Keyword) > 0 Then
attachObj.Add fileStorePath & filename
End If
filename = Dir()
Loop
End Sub
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
■１
VBAの世界では基本的にブックやシート、セルなど（オブジェクトといいます）は、きちんと明示すればいちいちアクティブにしたり選択したりする必要はありません。
また、【標準モジュール】でシートの指定を省略した場合、ActiveSheetが指定されたものとみなされるルールです。
したがって、想定していないものを処理しないためにも、対象のオブジェクトをきちんと指定することをお勧めします。
■２
「Sub～End Sub」までが一つのプロシージャと呼ばれるかたまりです。
提示されるなら、極力最初から最後まで提示されたほうがお互いの誤解が無くてよいでしょう。
■３
こだわりが無ければ、インデントを入れることを検討してみてください。（特に二重ループの部分など）
適切なインデントを付けることにより、コードの構造が把握しやすくなりご自身のデバッグ作業の効率アップに寄与すると思います。
■４
ネットで見かけたコードの研究や、自分で組んだコードの検証は【ステップ実行】という方法を使うと、１行ずつ実行でき便利です。
ステップ実行という言葉をご存じなければ↓をお読みください。
【ステップ実行】 https://www.239-programing.com/excel-vba/basic/basic023.html http://plus1excel.web.fc2.com/learning/l301/t405.html
【ブレークポイント】 https://www.239-programing.com/excel-vba/basic/basic022.html https://www.tipsfound.com/vba/01010
また↓も覚えておいて損はないでしょう。
【イミディエイトウィンドウ】 https://www.239-programing.com/excel-vba/basic/basic024.html https://excel-ubara.com/excelvba1/EXCELVBA486.html
【ローカルウィンドウ】 https://excel-ubara.com/excelvba4/EXCEL266.html http://excelvba.pc-users.net/fol8/8_2.html
（もこな２） 2022/09/25(日) 12:01
Sub 名無しのマクロ()
Dim k As Long
Dim i As Long '★宣言漏れ
Dim FC1 As Worksheet, FC As Worksheet '未定義
Dim WBNEW As Workbook, Ws As Worksheet
Dim LC1 As Long '★未定義（というかタイトル行の最終列だろうから固定では？）
Dim x As Long, ROWSFC1 As Long '★未定義
Dim MSG As Variant '★追加
Dim LC2 As Long, LR2 As Long '最終列の宣言・最終行の宣言
Dim MCR As Worksheet '★未定義
MSG = Array("いつもお世話になり有難うございます。", _
"カッティング機用部材 発注予測数量をご連絡させて頂きます。", _
"こちらの数量は予測数量であり、変更になる可能性がございます。", _
"ご了承頂けますようお願いいたします。")
Set FC1 = Worksheets("なんかのシート")
With FC1 'FC1.Selectを置き換え
For i = 4 To .Cells(.Rows.Count, "A").End(xlUp).Row ' 'FORECAST SUMMARYの4行目から最終行まで
If .Cells(i, 1).Value <> .Cells(i - 1, 1).Value Then
Set Ws = Workbooks.Add.Worksheets(1)
.Range("B2", .Cells(3, LC1)).Copy Ws.Range("A8")
k = 10
'▼B列～G列、H列～LC1（多分タイトル行の最終列）までをコピーして、A列以降に貼り付けているから1つにまとめられるはず
.Cells(i, 2).Resize(, 6).Copy Ws.Cells(k, 1)
.Cells(i, 8).Resize(LC1 - 7).Copy Ws.Cells(k, 7)
k = k + 1
For x = i + 1 To ROWSFC1 'FORECAST SUMMARYのi行プラス1行から最終行まで
If FC1.Cells(x, 1).Value = FC1.Cells(i, 1).Value Then
Ws.Cells(k, 1).Resize(6).Value = .Cells(x, 2).Resize(6).Value
.Cells(x, 8).Resize(LC1 - 7).Copy Ws.Cells(k, 7)
k = k + 1
'Else ←★記載不要
End If
Next x
'仕入先毎のBOOK加工
Ws.Range("A1").Value = .Cells(i, 1).Value & "様"
Ws.Range("A3:A6").Value = WorksheetFunction.Transpose(MSG)
Ws.Range("A8").Value = "品番"
Ws.Range("B8").Value = "品名" & vbLf & "メーカー品番"
Ws.Range("F8").Value = "向け地"
Ws.Range("G8").Value = "発注予測数量"
'仕入先毎BOOKの最終列・最終行取得
LC2 = Ws.Range("G9").End(xlToRight).Column
LR2 = FC.Cells(Rows.Count, 1).End(xlUp).Row
Ws.Cells(1, LC2).Value = Date
Ws.Cells(2, LC2).Value = MCR.Range("E42").Value
Ws.Cells(3, LC2).Value = MCR.Range("E44").Value
Ws.Range("C10", Ws.Cells(LR2, 5)).NumberFormat = "#,###" 'MOQ MPQ数量にコンマ入れる
'表 書式の設定
With Ws.Range("A8").CurrentRegion
.Borders.LineStyle = True '枠線を入れる
.BorderAround Weight:=xlMedium, LineStyle:=xlContinuous
.Font.Name = "Arial Unicode MS" 'フォント指定
End With
Ws.Range("A10").Resize(, LC2).Borders(xlEdgeTop).LineStyle = xlDouble '二重線入れる
'列幅の設定
Ws.Range("A:B").ColumnWidth = 26 'PARTNO・品名/ﾒｰｶｰ品番
Ws.Range("C:E").ColumnWidth = 8.5 'LEAD TIME MOQ MPQ
Ws.Range("F:F").ColumnWidth = 11 '向け地
Ws.Range("G1").Resize(LC2 - 6).EntireColumn.ColumnWidth = 13
'文字左詰め 中央 右詰め
Ws.Range("A:B").HorizontalAlignment = xlLeft
Ws.Range("C1").Resize(LC2 - 2).HorizontalAlignment = xlCenter
Ws.Range("A8:A9").HorizontalAlignment = xlCenter
Ws.Cells(1, LC2).Resize(3).HorizontalAlignment = xlRight
'1,2,6列目縮小して表示
Ws.Cells(10, 1).Resize(LR2 - 9).ShrinkToFit = True
Ws.Range("B1,F1").EntireColumn.ShrinkToFit = True
'フォント指定
Ws.Cells.Font.Name = "Arial Unicode MS"
Application.Goto Ws.Range("A1") 'A1選択
'ページ設定
With Ws.PageSetup
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
.CenterHorizontally = True
.Orientation = xlLandscape
End With
With Ws.Parent
.SaveAs FC1.Parent.Path & "\" & Format(Date, "yyyymmdd") & "_FORECAST_" & Ws.Range("A1").Value
.Close False
End With
'Else ←★記載不要
End If
Next i
End With
End Sub
（もこな２） 2022/09/25(日) 13:36
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.