VBA ＥＸＣＥＬからメールを送る方法について

今EXＣＥＬに書かれているのが
専用ならaqaurius0319,フレッツならshunsuke,INSならb230420
に送るＶＢＡを書いているのですが専用とだけ書かれていても全員に送られてしまいます
また専用、フレッツ、ＩＮＳと書かれているなら全員に送れるようにしたいです
どうしたらよろしいでしょうか？
Sub goosample()
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) = "shusnsuke": k(2, 1) = "b230420"
Set Bk = Workbooks.Open(file)
f1 = False
For Each SH In Bk.Worksheets
For i = 0 To UBound(k, 1)
If mailTo <> "" Then
mailTo = mailTo & " ;" & k(i, 1)
Else
mailTo = k(i, 1)
f1 = True
End If
Next
Next
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

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

• 

  すいません
  どこにどう組み込んだらいいか教えて貰ってもいいですか？
  素人なので助けてください

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

• ①Excelのブックに、シートが幾つかあるのでしょうか？
  
  回答 あります
  
  ②いくつかあるなら、全てのシートの中から、専用、フレッツ、ＩＮＳを
  探すので合っているでしょうか？
  
  回答 そうです
  
  ④書かれているセルは、特定できないのでしょうか？
  
  回答 毎回変わるので特定できません
  
  ⑤セルに書かれているのは、"専用"、"フレッツ"、"ＩＮＳ"　の３つだけを
  探すで良いのでしょうか？　前後に文字や空白はないと思って良い？
  
  回答 前後に文字があります

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

• Else
  mailTo = k(i, 1)
  f1 = True
  End If
  Next
  Next
  でnextに対応するforがありませんとでます

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

• すいません
  エラー無く起動はするのですが
  excelに専用とかかれていても宛先が空欄になってしまいます

  No.4の回答に寄せられた補足コメントです。 補足日時：2021/11/04 09:32

• すいません
  空欄の問題は解決したのですが専用とフレッツとINS全てあるときb230420にだけ送られてしまいます

    補足日時：2021/11/04 09:50

No.1 回答者： mygoonickname 回答日時： 2021/11/04 06:40

おはようございます。

For Each SH In Bk.Worksheets
For i = 0 To UBound(k, 1)
If mailTo <> "" Then
mailTo = mailTo & " ;" & k(i, 1)
Else
mailTo = k(i, 1)
f1 = True
End If
Next
Next

？？？
IFで k(i, 1)との判定がないので、全てスルーしているからだと思いますが。
前回のFINDの検索か、以前に提示した内容のCOUNTIF関数などを
組み込んで下さい。

No.2 回答者： mygoonickname 回答日時： 2021/11/04 07:10

詳しい説明をお願いしたいと、以前に書いた様な気がするのですが。

。。

書かれたマクロと、質問者さんの質問内容だけですと、推測しながらの
回答になるので、マクロコードを書いても、きっと、思った通りに動かない事になるかと。

こちらは、Excelシートは見れないですし、どの様な構成になっているかも
分らない状態なので、正確に把握しないと、回答ができないです。

下記の質問に
①Excelのブックに、シートが幾つかあるのでしょうか？
②いくつかあるなら、全てのシートの中から、専用、フレッツ、ＩＮＳを
探すので合っているでしょうか？
③１つのシートだけでしたら、どのシートかの指定が必要です。
④書かれているセルは、特定できないのでしょうか？
⑤セルに書かれているのは、"専用"、"フレッツ"、"ＩＮＳ"　の３つだけを
探すで良いのでしょうか？　前後に文字や空白はないと思って良い？

取り合えず、上記の回答をお願いします。

No.3 回答者： mygoonickname 回答日時： 2021/11/04 07:40

了解しました。

例えば、下記はどうでしょうか？
うまく行かない場合は、詳細を教えて下さい。
全シートで、Couuntif関数の、*を付けてあれば、個数を返します。
それが１つ以上なら、Mailアドレスを追加しています。
f1がTrueなら、１つ以上MailToにアドレスが入っているので、それを利用
しています。

Sub goosample()
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)
Dim myRng as Range
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, 1) & "*")>0 Then
IF fi Then
mailTo = mailTo & " ;" & k(i, 1)
Else
mailTo = k(i, 1)
f1 = True
End If
Next
Next

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

No.4 回答者： mygoonickname 回答日時： 2021/11/04 09:27

失礼しました。

End Ifが１つ抜けていた様です。　追加しました。
下記で、構文エラーはなくなったと思います。　Dimはまとめています。

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, 1) & "*") > 0 Then
If fi 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.5 ベストアンサー 回答者： mygoonickname 回答日時： 2021/11/04 09:55

失礼しました。

CountIf内のk(i, 0)と、If fi Thenが、間違っていました。
Option Explicit　を追加しています。

私のPCに、Outlookのメールはインストールしていないので、その部分は
確認できていませんが、それ以外は正常に動作するのを確認したので、
これでどうでしょうか？


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