メール画面表示マクロ

Sub メール画面表示マクロ()
Dim outlookApp As Object
Dim outlookMail As Object
Dim wsAddress1 As Worksheet
Dim wsAddress2 As Worksheet
Dim wsMailBody As Worksheet
Dim csvFile As Workbook
Dim csvFilePath As String
Dim recipients1 As String
Dim recipients2 As String
Dim title As String
Dim body As String
Dim lastRow As Long
Dim i As Long

' Outlookアプリケーションを作成
Set outlookApp = CreateObject("Outlook.Application")

' アドレス1シート、アドレス2シート、メール本文シートを指定
Set wsAddress1 = ThisWorkbook.Sheets("アドレス1")
Set wsAddress2 = ThisWorkbook.Sheets("アドレス2")
Set wsMailBody = ThisWorkbook.Sheets("メール本文")

' アドレス1シートとアドレス2シートの内容をクリア
wsAddress1.Cells.Clear
wsAddress2.Cells.Clear

' CSVファイルの検索と取得
csvFilePath = Dir(ThisWorkbook.Path & "\*.csv")
If csvFilePath <> "" Then
' CSVファイルを開く
Set csvFile = Workbooks.Open(ThisWorkbook.Path & "\" & csvFilePath)

' メールアドレスを取得し、アドレス1シートとアドレス2シートに分割
lastRow = csvFile.Sheets(1).Cells(csvFile.Sheets(1).Rows.Count, "D").End(xlUp).Row

For i = 1 To WorksheetFunction.Min(280, lastRow)
wsAddress1.Cells(i, 1).Value = csvFile.Sheets(1).Cells(i, 4).Value
Next i

For i = 281 To lastRow
wsAddress2.Cells(i - 280, 1).Value = csvFile.Sheets(1).Cells(i, 4).Value
Next i

' CSVファイルを閉じる
csvFile.Close
Else
MsgBox "CSVファイルが見つかりませんでした。"
Exit Sub ' CSVファイルがない場合は処理を終了
End If

' タイトルと本文を取得
title = wsMailBody.Range("B1").Value
body = wsMailBody.Range("B2").Value

' BCC用のメールアドレスを設定
For i = 1 To 280
recipients1 = recipients1 & wsAddress1.Cells(i, 1).Value & ";"
Next i

For i = 1 To lastRow - 280
recipients2 = recipients2 & wsAddress2.Cells(i, 1).Value & ";"
Next i

' メールアイテムを作成し、アドレス1シートのメールアドレスにBCCでメール作成画面を表示
Set outlookMail = outlookApp.CreateItem(0)
With outlookMail
.BCC = recipients1
.Subject = title
.body = body
.Display
End With

' メールアイテムを作成し、アドレス2シートのメールアドレスにBCCでメール作成画面を表示
Set outlookMail = outlookApp.CreateItem(0)
With outlookMail
.BCC = recipients2
.Subject = title
.body = body
.Display
End With

' Outlookアプリケーションを終了
Set outlookApp = Nothing
End Sub

Sub ConvertCSVToANSIAndProcessData()
' 本エクセルファイルのパスを取得
Dim excelPath As String
excelPath = ThisWorkbook.Path & "\"

' csvファイルのパスを作成
Dim csvPath As String
csvPath = Dir(excelPath & "*.csv")

' csvファイルが存在するか確認
If Len(csvPath) = 0 Then
MsgBox "csvファイルが見つかりません。", vbExclamation
Exit Sub
End If

' csvファイルをテキストエディタで開く
Dim fileNumber As Integer
fileNumber = FreeFile
Open excelPath & csvPath For Input As fileNumber

' テキストエディタで新しいファイルを作成し、ANSI形式で保存
Dim newFileName As String
newFileName = Replace(csvPath, ".csv", "_ANSI.csv")
Dim newFilePath As String
newFilePath = excelPath & newFileName
Dim newFileNumber As Integer
newFileNumber = FreeFile
Open newFilePath For Output As newFileNumber

' テキストエディタから読み込んでANSI形式で新しいファイルに書き込む
Dim lineText As String
Do While Not EOF(fileNumber)
Line Input #fileNumber, lineText
Print #newFileNumber, lineText
Loop

' ファイルを閉じる
Close fileNumber
Close newFileNumber

' 新しいCSVファイルをエクセルで開く
Workbooks.OpenText Filename:=newFilePath, DataType:=xlDelimited, Comma:=True

' A部署およびB部署を含む項目をC列で除外する
Dim ws As Worksheet
Set ws = ActiveSheet
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

Dim i As Long
For i = lastRow To 1 Step -1
If InStr(1, ws.Cells(i, 3).Value, "A部署") > 0 Or InStr(1, ws.Cells(i, 3).Value, "B部署") > 0 Then
ws.Rows(i).Delete
End If
Next i

' ファイルを保存
ActiveWorkbook.Save

MsgBox "変換とデータ処理が完了しました。新しいファイル: " & newFileName, vbInformation
End Sub