excel VBAでメールを送る方法について

ExcelのVBAなんですがエクセルに専用と書いていても"無かった"と表示されてしまします
なぜでしょうか？
Sub 最終sample()
Const olMailItem = 0
Dim file As String
Dim pr As Workbook
Dim sl As Worksheet
Dim sh As Shape
Dim tb As Table
Dim r As Integer
Dim c As Integer
Dim s As String

Dim f1 As Boolean
Dim f2 As Boolean
Dim ol As Object
Dim mail As Object
Dim f As Object
Dim dic As Object
Dim k As Variant
Dim n As Variant
Dim mailTo As String

With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "xlsx", "*.xlsx?"
.InitialFileName = "C:\"
.AllowMultiSelect = False
If Not .Show Then Exit Sub
file = .SelectedItems(1)
End With

Do
Set pr = Workbooks.Open(file)
For Each sl In pr.Worksheets
f1 = False
f2 = False
For Each sh In sl.Shapes
If sh.HasTable Then
Set tb = sh.Table
For r = 1 To tb.Rows.Count
For c = 1 To tb.Rows(r).Cells.Count
s = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
'宛先
If InStr(s, "専用") Then
f1 = True
mailTo = "aquarius0319"
End If
If InStr(s, "フレッツ") Then
f1 = True
mailTo = "b230420"
End If
If InStr(s, "INS") Then
f1 = True
mailTo = "b230420"
End If
If f1 Then Exit Do
Next
Next
End If
Next
Next
MsgBox "無かった"
Loop Until True
pr.Close

If Not (f1) Then Exit Sub
'
MsgBox "見つけた"


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
Dim o As Integer
For o = 1 To .SelectedItems.Count
mail.Attachments.Add .SelectedItems(o)
Next
End If
End With

'メール送信
mail.Send '送信

ol.Quit

End Sub

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

• コードを見るとシェイプが出てきておりますが、Excelはセルの値で良いのでしょうか？
  
  回答 そうです
  
  IFで"専用"などを探しているようですが、
  キーワードが2つあった場合は、どのような優先順位をお考えですか？
  2つキーワードがあった時は2か所のアドレスを作るのでしょうか？
  
  回答 2つのキーワードがあったら2箇所におくります
  
  すいません
  自分では変えれなそうです‥

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

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2021/11/03 17:17

>2つキーワードがあった時は2か所のアドレスを作るのでしょうか？

#1 k(2, 2) = "b230420"ミスがあったので　下記に書き替えたサンプルを出します。

配列作成以下対象ブックを開いて閉じるところのサンプルです。
ちなみにOUTLOOKメールアドレスをつなげるのは、 半角スペース＋セミコロンだったかと記憶していますが、違うかもです。

k(0, 0) = "専用": k(1, 0) = "フレッツ": k(2, 0) = "INS"
k(0, 1) = "aquarius0319": k(1, 1) = "b230420": k(2, 1) = "b230420"
Set Bk = Workbooks.Open(file)
f1 = False
For Each SH In Bk.Worksheets
If Not SH.UsedRange.Find(What:="秋田", LookAt:=xlPart) Is Nothing Then
For i = 0 To UBound(k, 1)
If Not SH.UsedRange.Find(What:=k(i, 0), LookAt:=xlPart) Is Nothing Then
If mailTo <> "" Then
mailTo = mailTo & " ;" & k(i, 1)
Else
mailTo = k(i, 1)
f1 = True
End If
End If
Next
End If
Next
Bk.Close

ちなみに改修しやすくするアドバイスとして
名簿データシートを作成して　その列にIDやキーワード、メルアドなどを
表にします。行方向はIDに対して関連項目になります。

VBAで配列を作る時や多くのキーワードを探す場合など表の範囲を指定すれば値を取得できます。

各項目が変更になる場合などそのシートを変更すれば、VBAコードを書き直す必要が減りますね。
シートは、通常表示できないようにVBAで非表示にすれば良いです。

No.1 回答者： Qchan1962 回答日時： 2021/11/03 16:15

こんにちは

コードを見るとシェイプが出てきておりますが、Excelはセルの値で良いのでしょうか？
IFで"専用"などを探しているようですが、
キーワードが2つあった場合は、どのような優先順位をお考えですか？
2つキーワードがあった時は2か所のアドレスを作るのでしょうか？

https://oshiete.goo.ne.jp/qa/12646659.htmlへのレスもないですが、
サンプルを示せを示せば、ご自身で改修出来ますか？

変な条件設定なので書き直しますね。
秋田がある事と"専用""フレッツ""INS"いづれかがある事でメールを作成します。
Sub sample()
Const olMailItem = 0
Dim file As String
Dim Bk As Workbook
Dim SH As Worksheet
Dim i As Long
Dim f1 As Boolean
Dim ol As Object
Dim mail As Object
Dim mailTo As String
Dim k(0 To 2, 0 To 2)
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) = "b230420": k(2, 2) = "b230420"
Set Bk = Workbooks.Open(file)
f1 = False
For Each SH In Bk.Worksheets
If Not SH.UsedRange.Find(What:="秋田", LookAt:=xlPart) Is Nothing Then
For i = 0 To UBound(k, 1)
If Not SH.UsedRange.Find(What:=k(i, 0), LookAt:=xlPart) Is Nothing Then
mailTo = k(i, 1)
f1 = True
GoTo HitKey
End If
Next
End If
Next
HitKey:
Bk.Close
If f1 = False Then
MsgBox "無かった"
Exit Sub
Else
MsgBox "見つけた"
End If
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
Dim o As Integer
For o = 1 To .SelectedItems.Count
mail.Attachments.Add .SelectedItems(o)
Next
End If
End With
'メール送信
mail.Send '送信
ol.Quit
End Sub