今wordで専用があればaquarius0319にフレッツがあればsyunsukeにINSがあればb

今wordで専用があればaquarius0319にフレッツがあればsyunsukeにINSがあればb230420に専用とフレッツとINSがあれば全員に送るVBAを作りたいのですがexcel版は出来たもののword版は知識不足で作れませんでした
どこを変更すればよろしいでしょうか？
Option Explicit

Sub goosample()
Const olMailItem = 0
Dim file As String, Bk As Workbook, SH As Worksheet, i As Long, f1 As Boolean
Dim ol As Object, mail As Object, mailTo As String, k(0 To 2, 0 To 2), myRng As Range, o As Integer
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "xls", "*.xls?"
.InitialFileName = "C:\"
.AllowMultiSelect = False
If Not .Show Then Exit Sub
file = .SelectedItems(1)
End With
k(0, 0) = "専用": k(1, 0) = "フレッツ": k(2, 0) = "INS"
k(0, 1) = "aquarius0319": k(1, 1) = "shusnsuke": k(2, 1) = "b230420"
Set Bk = Workbooks.Open(file)
f1 = False
mailTo = ""
For Each SH In Bk.Worksheets
SH.Select
For i = 0 To UBound(k, 1)
Set myRng = SH.UsedRange
If Application.WorksheetFunction.CountIf(myRng, "*" & k(i, 0) & "*") > 0 Then
If f1 Then
mailTo = mailTo & " ;" & k(i, 1)
Else
mailTo = k(i, 1)
f1 = True
End If
End If
Next i
Next SH
Set ol = CreateObject("Outlook.Application")
Set mail = ol.CreateItem(olMailItem)
mail.Display
mail.To = mailTo '宛先
mail.Subject = "件名"
mail.Body = "本文"
'添付ファイル
mail.Attachments.Add file
'添付ファイル
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "添付ファイル", "*.*"
.InitialFileName = "C:\"
.AllowMultiSelect = True
If .Show Then
For o = 1 To .SelectedItems.Count
mail.Attachments.Add .SelectedItems(o)
Next
End If
End With
'メール送信
mail.Send '送信
ol.Quit
End Sub

質問者からの補足コメント

• すいません
  質問のコードも教えてもらったものなので理解できていません
  申し訳ありませんがコードを全文書いてもらってもよろしいでしょうか？

  No.2の回答に寄せられた補足コメントです。 補足日時：2021/11/14 15:22

• まったく見当もつきません

  No.3の回答に寄せられた補足コメントです。 補足日時：2021/11/14 16:49

No.4 回答者： Qchan1962 回答日時： 2021/11/14 23:18

#3です

ご質問を返しましたので、このまま放置する事は失礼と思い回答をいたします。
個人的な回答ですが、私の回答、サンプルコードは開発者の為のものです。

開発、プログラム作成をしたい方が基本的にご質問をされていると思っています。
～するものを作りたい方に対しての回答です
～するものを使いたい方への回答ではありません。

示したサンプルが、したい事を処理できたとしても　そのコードはサンプルであり　デバッグを繰り返し検証したものではありません。したがってデバッグや検証、内容については、質問者自身が自己責任で検証し、デバッグする事が必要です。
これらを、開発者は理解しているものと思います

ご質問の処理は、大げさな処理では無いと思いますので
プロの作成会社に依頼されるのが、最も幸せになれる手段と存じます。

時間経費を考えれば、費用をかけて作ってもらっても相当安いと思います。
お力になれず、すみません。

No.3 回答者： Qchan1962 回答日時： 2021/11/14 16:43

こんにちは

＃１，＃２には不備不足がありましたので付け加えます。
Set wdApp = CreateObject("Word.Application")　となっておりますが、
wordのメソッド、プロパティを操作する為、事前バインディングをしてください。

一部は私が書いたものそのままなので、初めから補足のようなコメントがあれば変わったかもしれませんね。

ご質問の目的を達成する為には、wordを開いてword内をキーで探して
キーに紐づくアドレスでOutlookの送信先アドレスを作り、Outlookのmail.To =に入れるで合っていますでしょうか？（Excelも同じ）
少なくとも、Excelではそのようになっています。

①ファイルを開く
②キーを設定するところ
③wordを開きアドレスを作る
④Outlookを開く
⑤添付ファイルなど各種を設定

ここで、③wordを開きアドレスを作る　が解らないと言うご質問と解釈しましたので　アドレスを作るサンプルとして記載しました。

＞申し訳ありませんがコードを全文書いてもらってもよろしいでしょうか？

現状、そのような気にはなりません。

全文を書いてもらうより、今あるものを理解した方が良いと思います。
全く見当もつかないのでしょうか？

No.2 回答者： Qchan1962 回答日時： 2021/11/12 00:47

＃１補足を忘れました

配列はシート上にマトリックスで書いている事を想定している為、インデックス1から始まる2次配列です。
ご質問コードの様に配列設定する場合は、0からになります。

No.1 回答者： Qchan1962 回答日時： 2021/11/12 00:40

こんばんは、

ご質問コードを理解しているとして
mailToを設定できれば良いものと思います。
mailToを取得するFunctionを書いてみました。
Wordだけだと解り難いと思いましたので引数分岐でExcelも出来るようにしましたのでご質問コードとExcel用Function、Word用を見比べて試してください。
Functionの引数は（フルパス、第一条件、キーワードとアドレスの配列）
戻り値はメールアドレスです。探す第一条件は空白でも良いですが、古いご質問にあった東京都や秋田でも仕様によって変えてください。

Private Function target_word(file As String, cd1 As String, k) As String
'--sharing
Dim i As Long
Dim mailTo As String: mailTo = ""
'--Word
If InStr(file, ".docx") > 0 Then
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim tmp As String
Set wdApp = CreateObject("Word.Application")
If file <> "" Then Set wdDoc = wdApp.Documents.Open(file) Else Exit Function
wdApp.Visible = True
For i = 1 To UBound(k, 1)
tmp = wdDoc.Content.Text
If InStr(tmp, cd1) > 0 Then
If InStr(tmp, k(i, 1)) > 0 Then
If mailTo <> "" Then
If InStr(mailTo, k(i, 2)) <= 0 Then mailTo = mailTo & " ;" & k(i, 2)
Else
mailTo = k(i, 2)
End If
End If
End If
Next i
target_word = mailTo
wdDoc.Close
wdApp.Visible = False
Set wdApp = Nothing
End If
'--Excel
If InStr(file, ".xls") > 0 Then
Dim Bk As Workbook
Dim SH As Worksheet
If file <> "" Then Set Bk = Workbooks.Open(file) Else Exit Function
For Each SH In Bk.Worksheets
If Not SH.UsedRange.Find(What:=cd1, LookAt:=xlPart) Is Nothing Then
For i = 1 To UBound(k, 1)
If Not SH.UsedRange.Find(What:=k(i, 1), LookAt:=xlPart) Is Nothing Then
If mailTo <> "" Then
If InStr(mailTo, k(i, 2)) <= 0 Then mailTo = mailTo & " ;" & k(i, 2)
Else
mailTo = k(i, 2)
End If
End If
Next
End If
Next
target_word = mailTo
Bk.Close
Set Bk = Nothing
End If
End Function