思い出も作品も3Dデータで残せる!

今EXCELに書かれているのが
専用ならaqaurius0319,フレッツならshunsuke,INSならb230420
に送るVBAを書いているのですが専用とだけ書かれていても全員に送られてしまいます
また専用、フレッツ、INSと書かれているなら全員に送れるようにしたいです
どうしたらよろしいでしょうか?
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のブックに、シートが幾つかあるのでしょうか?

    回答 あります

    ②いくつかあるなら、全てのシートの中から、専用、フレッツ、INSを
    探すので合っているでしょうか?

    回答 そうです

    ④書かれているセルは、特定できないのでしょうか?

    回答 毎回変わるので特定できません

    ⑤セルに書かれているのは、"専用"、"フレッツ"、"INS" の3つだけを
    探すで良いのでしょうか? 前後に文字や空白はないと思って良い?

    回答 前後に文字があります

    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
gooドクター

A 回答 (5件)

失礼しました。



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
    • good
    • 0

失礼しました。

End Ifが1つ抜けていた様です。 追加しました。
下記で、構文エラーはなくなったと思います。 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
この回答への補足あり
    • good
    • 0

了解しました。


例えば、下記はどうでしょうか?
うまく行かない場合は、詳細を教えて下さい。
全シートで、Couuntif関数の、*を付けてあれば、個数を返します。
それが1つ以上なら、Mailアドレスを追加しています。
f1がTrueなら、1つ以上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
この回答への補足あり
    • good
    • 0

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

。。

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

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

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

取り合えず、上記の回答をお願いします。
この回答への補足あり
    • good
    • 0

おはようございます。



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関数などを
組み込んで下さい。
この回答への補足あり
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

gooドクター

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング