はりつける

Sub ReplaceFolderNames()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim folderPath As String, searchName As String, replaceName As String
Dim folder As Object, fso As Object

Set ws = ThisWorkbook.Sheets(1) ' 1番目のシートを使用
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' A列の最終行を取得

Set fso = CreateObject("Scripting.FileSystemObject")
folderPath = ThisWorkbook.Path ' ThisWorkbookがあるフォルダのパス

' 2行目から最終行までループ
For i = 2 To lastRow
searchName = ws.Cells(i, 1).Value ' A列の値（検索文字列）
replaceName = ws.Cells(i, 2).Value ' B列の値（置換文字列）

' フォルダ名の置換を試みる
If fso.FolderExists(folderPath & "\" & searchName) Then
Set folder = fso.GetFolder(folderPath & "\" & searchName)
Name folder.Path As folderPath & "\" & replaceName
End If
Next i

Set fso = Nothing
MsgBox "Folder names have been replaced."
End Sub

はりつけ

Sub CopyDataFromMultipleWorkbooks()
' 変数宣言
Dim wsTemplate As Worksheet, wsNew As Worksheet
Dim wbSource As Workbook
Dim strFolderPath As String, strFileName As String
Dim selectedMonth As String
Dim targetColumn As Integer

' ユーザーに月名の入力を求める
selectedMonth = Application.InputBox("シート名を指定してください（例: 1月、2月）", Type:=2)

' 雛形シートを複製し、新しいシート名をユーザーが選択した月名に設定
Set wsTemplate = ThisWorkbook.Sheets("雛形シート")
wsTemplate.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Set wsNew = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wsNew.Name = selectedMonth

' データ読み込み用のフォルダパスを設定
strFolderPath = ThisWorkbook.Path & "\reply\"
strFileName = Dir(strFolderPath & "*.xlsx")

' 初期列（B列）の設定
targetColumn = 2

' フォルダ内のすべてのワークブックを処理
Do While strFileName <> ""
Set wbSource = Workbooks.Open(strFolderPath & strFileName)

' 対象のワークブックに選択された月のシートがあるか確認
If SheetExists(selectedMonth, wbSource) Then
' AB列のデータを新しいシートにコピー
wsNew.Cells(1, targetColumn).Value = wbSource.Name
wbSource.Sheets(selectedMonth).Range("AB2:AB" & wbSource.Sheets(selectedMonth).Cells(Rows.Count, "AB").End(xlUp).Row).Copy
wsNew.Cells(2, targetColumn).PasteSpecial Paste:=xlPasteValues

' 次の列へ移動
targetColumn = targetColumn + 1
End If

' ワークブックを閉じる
wbSource.Close False
strFileName = Dir
Loop

' コピー操作終了後のクリーンアップ
Application.CutCopyMode = False
MsgBox "データのコピーが完了しました。"
End Sub

' シートが存在するかどうかを確認する関数
Function SheetExists(sheetName As String, wb As Workbook) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = wb.Sheets(sheetName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function

シートの値を転記

Sub TransferData()
Dim ws As Worksheet
Dim newWorkbook As Workbook
Dim newRow As Integer
Dim cellValueE12 As Variant, cellValueE13 As Variant

' 新規ワークブックを作成
Set newWorkbook = Workbooks.Add
newRow = 1

' ThisWorkbookの各シートをループ
For Each ws In ThisWorkbook.Sheets
' E12とE13のセル値を取得
cellValueE12 = ws.Range("E12").Value
cellValueE13 = ws.Range("E13").Value

' 新規ワークブックにデータを転記
With newWorkbook.Sheets(1)
.Cells(newRow, 1).Value = ws.Name
.Cells(newRow, 2).Value = cellValueE12
.Cells(newRow, 3).Value = cellValueE13
End With
newRow = newRow + 1
Next ws
End Sub

検索一致をB列に返す

Sub SearchTextInWordDocument()
' 必要な変数の宣言
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim selectedFile As Variant
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim searchText As String
Dim searchCount As Long

' ユーザーにファイル選択ダイアログを表示し、.docxファイルを選択させる
selectedFile = Application.GetOpenFilename("Word Documents (*.docx), *.docx", , "Select a Word Document")

' ファイルが選択されたか確認
If selectedFile = False Then Exit Sub

' Wordアプリケーションを開く
Set wordApp = New Word.Application
' 選択されたWord文書を開く
Set wordDoc = wordApp.Documents.Open(selectedFile)

' Excelのシート1を設定
Set ws = ThisWorkbook.Sheets("Sheet1")
' A列の最終行を取得
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

' 2行目から最終行までループし、各行のテキストをWord文書で検索
For i = 2 To lastRow
searchText = ws.Cells(i, 1).Value
' 指定されたテキストの出現回数をカウントし、B列に記録
searchCount = CountWordOccurrences(wordDoc, searchText)
ws.Cells(i, 2).Value = searchCount
Next i

' Word文書を保存して閉じる
wordDoc.Close True
' Wordアプリケーションを閉じる
wordApp.Quit

' オブジェクトを解放
Set wordDoc = Nothing
Set wordApp = Nothing

' 完了メッセージを表示
MsgBox "検索が完了しました。", vbInformation
End Sub

Function CountWordOccurrences(doc As Word.Document, searchText As String) As Long
' 必要な変数の宣言
Dim range As Word.Range
Dim count As Long
count = 0

' Word文書の内容全体を範囲として設定
Set range = doc.Content
With range.Find
' 検索設定
.Text = searchText ' 検索するテキスト
.Format = False ' フォーマットは使用しない
.MatchCase = False ' 大文字と小文字の区別をしない
.MatchWholeWord = True ' 単語全体に一致するものだけを検索
.MatchWildcards = False ' ワイルドカードは使用しない
.MatchSoundsLike = False ' 類似音は考慮しない
.MatchAllWordForms = False ' すべての単語形式に一致するものを検索しない

' 文書内を検索し、一致する箇所をカウント
Do While .Execute(Forward:=True, Wrap:=Word.WdFindWrap.wdFindContinue)
' 検索に一致した箇所にピンクのハイライトを適用
range.HighlightColorIndex = Word.WdColorIndex.wdPink
count = count + 1
Loop
End With

' 出現回数を返す
CountWordOccurrences = count
End Function

差し込み情報付きドラフトメールを作成

' 指定されたテンプレート文字列内のプレースホルダーを実際のデータで置き換える関数
Function ReplacePlaceholders(ByVal template As String, ByVal ws As Worksheet, ByVal rowNum As Long) As String
' 置き換えるプレースホルダーの配列
Dim placeholders As Variant
placeholders = Array("{宛名}", "{テキスト1}", "{テキスト2}", "{テキスト3}")

Dim i As Integer
' プレースホルダーを実際のセルのデータで置き換える
For i = LBound(placeholders) To UBound(placeholders)
template = Replace(template, placeholders(i), ws.Cells(rowNum, i + 1).Value)
Next i

' 置き換え後のテンプレートを返す
ReplacePlaceholders = template
End Function

' メールの下書きを作成するメインサブルーチン
Sub CreateEmailDraftsWithSender()
Dim wsMail As Worksheet, wsTemplate As Worksheet
' メール送信とメールテンプレートのシートを設定
Set wsMail = ThisWorkbook.Sheets("メール送信")
Set wsTemplate = ThisWorkbook.Sheets("メールテンプレート")

Dim OutApp As Object
' Outlookアプリケーションのオブジェクトを作成し、ログイン
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

Dim lastRow As Long
' メール送信シートの最終行を取得
lastRow = wsMail.Cells(wsMail.Rows.Count, "A").End(xlUp).Row

Dim i As Long
' 各行をループし、条件に合致する行でメール下書きを作成
For i = 2 To lastRow
If wsMail.Cells(i, 5).Value = "メールを送る" Then
CreateDraft OutApp, wsMail, wsTemplate, i
End If
Next i

' 完了メッセージボックスを表示
MsgBox "メールの下書きを作成しました", vbInformation
End Sub

' メールの下書きを作成するサブルーチン
Sub CreateDraft(ByVal OutApp As Object, ByVal wsMail As Worksheet, ByVal wsTemplate As Worksheet, ByVal rowNum As Long)
On Error GoTo ErrorHandler
' メールテンプレートから件名と本文を取得し、プレースホルダーを置き換え
Dim mailSubject As String, mailBody As String
mailSubject = ReplacePlaceholders(wsTemplate.Cells(1, 2).Value, wsMail, rowNum)
mailBody = ReplacePlaceholders(wsTemplate.Cells(2, 2).Value, wsMail, rowNum)

Dim OutMail As Object
' Outlookメールアイテムの作成と設定
Set OutMail = OutApp.CreateItem(0)
With OutMail
' F列（差出人）、G列（To）、

H列（CC）、I列（BCC）から情報を取得し設定
.SentOnBehalfOfName = wsMail.Cells(rowNum, 6).Value ' F列（差出人）
.To = wsMail.Cells(rowNum, 7).Value ' G列（To）
.CC = wsMail.Cells(rowNum, 8).Value ' H列（CC）
.BCC = wsMail.Cells(rowNum, 9).Value ' I列（BCC）
.Subject = mailSubject ' 件名
.Body = mailBody ' 本文
.Save ' 下書きとして保存
End With

' Outlookメールアイテムのオブジェクトを解放
Set OutMail = Nothing
Exit Sub

ErrorHandler:
' エラー発生時の処理
MsgBox "エラーが発生しました: " & Err.Description, vbCritical
' オブジェクトを解放
Set OutMail = Nothing
End Sub

値の削除

Sub ClearDataAndFormatting()
Dim ws As Worksheet
Dim LastRow As Long

' Excelシートの設定
Set ws = ThisWorkbook.Sheets("メール送付_一括送付")

' 最終行を取得
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' E列、F列、G列の既存データをクリアし、セルの色塗りを解除
With ws
.Range(.Cells(2, "E"), .Cells(LastRow, "G")).ClearContents
.Range(.Cells(2, "E"), .Cells(LastRow, "G")).Interior.ColorIndex = 0 ' セルの色塗りを解除
End With
End Sub

返信状況確認

Sub CopyEmailContentsToSheet()
Dim OutlookApp As Object
Dim OutNamespace As Object
Dim SharedInbox As Object
Dim MailItem As Object
Dim ws As Worksheet
Dim i As Long, j As Integer
Dim Found As Boolean

On Error GoTo ErrorHandler

' Excelシートの設定
Set ws = ThisWorkbook.Sheets("メール送付_一括送付")

' Outlookのインスタンスを開始
Set OutlookApp = CreateObject("Outlook.Application")
Set OutNamespace = OutlookApp.GetNamespace("MAPI")

' 共有アカウントのメールアドレスを設定
Dim SharedMailboxAddress As String
SharedMailboxAddress = "shared@domain.com"

' 共有アカウントの受信トレイを取得
Set SharedInbox = OutNamespace.GetSharedDefaultFolder(OutNamespace.CreateRecipient(SharedMailboxAddress), 6) ' 6は受信トレイ

' Excelシートをループ処理
For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If ws.Cells(i, "E").Value <> "" Then ' E列が空欄でない場合のみ処理
Found = False
j = 0

' メールアイテムをループ処理
For Each MailItem In SharedInbox.Items
If InStr(MailItem.Subject, ws.Cells(i, "E").Value) > 0 And (MailItem.SenderEmailAddress = ws.Cells(i, "B").Value Or MailItem.SenderEmailAddress = ws.Cells(i, "C").Value Or MailItem.SenderEmailAddress = ws.Cells(i, "D").Value) Then
' メールの内容を転記
j = j + 1
If j > 3 Then
MsgBox "該当メールが4件以上あります"
Exit Sub
End If
ws.Cells(i, "F").Offset(0, j - 1).Value = MailItem.Body
Found = True
End If
Next MailItem

' 該当メールがない場合の処理
If Not Found Then
ws.Cells(i, "F").Interior.Color = RGB(255, 255, 0) ' 黄色に着色
End If
End If
Next i

GoTo CleanUp

ErrorHandler:
MsgBox "エラーが発生しました: " & Err.Description
GoTo CleanUp

CleanUp:
' オブジェクトの解放
Set SharedInbox = Nothing
Set OutNamespace = Nothing
Set OutlookApp = Nothing
End Sub
```

この修正により、該当するメールが見つからなかった場合に、該当行のE列のセルが黄色に着色されます。これにより、視覚的に該当メールがない行を簡単に識別できます。