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

Question

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

Comments

[cx20]

以前にも書きましたが、デバッグ実行して処理が呼ばれているか確認してみて下さい。
VBAの場合、F8キーでステップ実行（１行ずつ実行）が行えます。

Answer 1

恐らく PowerPoint を扱う VBA のコードを Excel の VBA に移植しようとされているのだと思いますが、PowerPoint と Excel で表の扱いが異なるのでそのあたりを理解する必要があります。

以下は PowerPoint と Excel で、それぞれ表の中から「専用」の文字を取得する方法になります。

■ PowerPoint の場合

Slides(2).Shapes(1).Table.Rows(2).Cells(1).Shape.TextFrame2.TextRange.Text

■ Excel の場合

Sheets(2).Cells(2,1)

Answer 2

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