Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = True
Worksheets("送信表").Cells.FormatConditions.Delete
Range(Worksheets("送信表").Cells(1, 2), Worksheets("送信表").Cells(101, 10)).FormatConditions.Add(Type:=xlExpression, Formula1:="=AND(CELL(""ROW"")=ROW(), CELL(""COL"")=COLUMN())").Interior.Color = rgbPowderBlue
End Sub
Public Function Search(ByVal Rng As Range, ByVal keyWord As Variant, ByVal Whole As Boolean) As Range
' 引数：
' Rng:検索範囲 (例) ActiveSheet.Range ("A1:Z500")
' KeyWord:検索する値 (例) "リンゴ",10,7.85
' Whole:完全一致→True 部分一致→False (例)True
' 戻り値
' Rangeオブジェクト 見つからなかった場合は「Nothing」
' 検索範囲内の「KeyWord」を検索する関数です。
' 検索範囲を一つずつ判定し、最初に一致したセル範囲を返します。
' 完全一致と部分一致対応できます。
' 非表示のセルも検索かけます
' 検索結果はセル範囲一つだけです。複数の場合が良ければ「search_List」関数を使ってください
' https://www.hokkyokun.com/vba-search-vs-findmethod/
Dim r As Range
'完全一致
If Whole Then
For Each r In Rng
If r.Value = keyWord Then
Set Search = r
Exit Function
End If
Next
'部分一致
Else
For Each r In Rng
If InStr(r.Value, keyWord) > 0 Then
Set Search = r
Exit Function
End If
Next
End If
'見つからなかった時の処理
'適宜変更してもらって構いません
Set Search = Range("XFD1048576") 'Range(1048576,16384)を返す--最終セル
End Function
この関数を呼び出すのに，次のようなサブルーチンを使いました。
Private Sub CommandButton7_Click()
Dim Hani, kensakukekka As Range
Set Hani = Range(Worksheets("マスター").Cells(2, 5), Worksheets("マスター").Cells(96, 5))
MsgBox Worksheets("マスター").Cells(2, 5) & Worksheets("マスター").Cells(96, 5)
kensakukekka = Search(Hani, "リンゴ", True)
MsgBox kensakukekka
End Sub
If DateValue(sousin) < DateValue("2030/01/22") Then 'ハワイ支部会員先行受付
If syubetu = "会員" And InStr(sibu, "ハワイ") > 0 Then
'何もしない
Else
objmailItem.Move objFolder_kikangai
End If
End If
このように書いていました。必要なのは，先行受付の期間では，該当しないメールを期間外のホルダーに移動
するのですが，先行受付に該当するメールには，何もしなくて，それ以外を期間外ホルダーに移すと考えた方
がわかりやすいです。（最も，私にとってはです・・・・。）
if の部分では，なにもしなくて，else で該当しないメールの処理をする，という記述ですが，この方法だ
と，処理が増えていくことを考えると下記のように NOT を使う記述がいいとのことでした。
If DateValue(sousin) < DateValue("2030/01/22") Then 'ハワイ支部会員先行受付
If Not(syubetu = "会員" And InStr(sibu, "ハワイ") > 0） Then
objmailItem.Move objFolder_kikangai
End If
End If
Dim WithEvents mySentItems As Items
Public Sub AddTrackInfo(ByVal objMail As MailItem, iRow As Integer, iCol As Integer)
Dim olkApp As Outlook.Application
Dim fldSentMail As Folder
Dim strTrackInfo As String
Dim propTrack As UserProperty
' 送信済みアイテム フォルダーを取得
Set fldSentMail = objMail.Application.Session.GetDefaultFolder(olFolderSentMail)
' mySentItems が設定されていなければ送信済みアイテム フォルダーの Items を設定
If mySentItems Is Nothing Then
Set mySentItems = fldSentMail.Items
End If
' メールに送信後の保存先フォルダーを設定
Set objMail.SaveSentMessageFolder = fldSentMail
' 送信状況を追跡するためのプロパティを設定
Set propTrack = objMail.UserProperties.Add("TrackInfo", olText, True)
' 送信日時を保存するセルの行番号と列番号を設定
propTrack.Value = iRow & "," & iCol
End Sub
' 送信済みアイテム フォルダーにアイテムが追加されたときに実行されるイベント
Public Sub mySentItems_ItemAdd(ByVal Item As Object)
Dim objMail As MailItem
Dim propTrack As UserProperty
Set objMail = Item
' 送信状況を追跡するプロパティの確認
Set propTrack = objMail.UserProperties.Find("TrackInfo")
' プロパティが存在したら
If Not propTrack Is Nothing Then
Dim arrRC As Variant
' 送信日時を保存するセルの行番号と列番号を取得
MsgBox propTrack.Value
arrRC = Split(propTrack.Value, ",")
' 取得した行、列のセルに送信日時を保存
Sheet1.Cells(CInt(arrRC(0)), CInt(arrRC(1))).Value = objMail.SentOn
End If
End Sub
For j = LBound(koumokuArray) To UBound(koumokuArray)
If InStr(preArray(i), koumokuArray(j)) > 0 Then
nukidasi = preArray(i + 1) '目的の項目の値は +1の配列に格納されている
koumoku = koumokuArray(j)
Exit For '見つかった時ループを抜ける
End If
Next j
For k = LBound(koumokuArray) To UBound(koumokuArray) '余分な項目を除く
nukidasi = Replace(nukidasi, koumokuArray(k), "")
Next k
のようにして，該当する項目を削除します。その後，koumoku に応じた外部変数に Select Case にて
記憶します。それぞれのケースでは，「県」「支部」「都」を除く処理や，文字長を制限する処理もしてあり
ます。
Select Case koumoku
Case "お名前"
simei = nukidasi
Case "ご所属"
syozoku = nukidasi
If Len(syozoku) > 20 Then
syozoku = Mid(syozoku, 1, 20)
End If
Case "電話"
denwa = nukidasi
Case "メールアドレス"
adoresu = nukidasi
Case "申し込み種別"
syubetu = nukidasi
Case "所属支部"
sibu = nukidasi
sibu = Replace(sibu, "支部", "")
sibu = Replace(sibu, "県", "")
If sibu <> "京都" Then
sibu = Replace(sibu, "都", "")
End If
Case "登録番号"
bangou = nukidasi
Case "会員番号"
kaiin_bangou = nukidasi
Case "郵便番号"
yubin = nukidas
Case "住所"
jyuusyo = nukidasi
Case "参加資格"
sanka_sikaku = nukidasi
End Select
以上が処理の流れですが，これをサブとして呼び出せるようにしてあります。以下が全文です。
Private Sub mail_koumoku_nukidasi(Honbun As String)
Dim preArray As Variant
Dim koumokuArray() As Variant
Dim buffer, buffer1, nukidasi,koumoku As String
Dim i, j, k As Integer
'最終項目の後の文字
buffer1 = "------------------------------------------------------------送信日時"
'予想される項目
koumokuArray = Array("お名前", "ご所属", "電話", "メールアドレス", "申し込み種別", "所属支部", "登録番号", "会員番号", "住所", "郵便番号", "参加資格")
'本文前処理
buffer = Mid(Honbun, InStr(Honbun, "お名前=")) '「お名前=」以前の項目を消す
buffer = Left(buffer, InStr(buffer, buffer1) - 1) '最終項目以下を消す
buffer = Replace(buffer, "ご所属先電話", "電話") '「ご所属」と「ご所属先電話」検索で区別が付かないので，置き換え
preArray = Split(buffer, "=") '"="を区切りで分割
For i = LBound(preArray) To UBound(preArray) - 1
For j = LBound(koumokuArray) To UBound(koumokuArray)
If InStr(preArray(i), koumokuArray(j)) > 0 Then
nukidasi = preArray(i + 1) '目的の項目は +1の配列に格納されている
koumoku = koumokuArray(j) '項目の保持
Exit For '見つかった時ループを抜ける
Exit For
End If
Next j
For k = LBound(koumokuArray) To UBound(koumokuArray) '余分な項目を除く
nukidasi = Replace(nukidasi, koumokuArray(k), "")
Next k
'項目に応じた変数に格納する
Select Case koumoku
Case "お名前"
simei = nukidasi
Case "ご所属"
syozoku = nukidasi
If Len(syozoku) > 20 Then
syozoku = Mid(syozoku, 1, 20)
End If
Case "電話"
denwa = nukidasi
Case "メールアドレス"
adoresu = nukidasi
Case "申し込み種別"
syubetu = nukidasi
Case "所属支部"
sibu = nukidasi
sibu = Replace(sibu, "支部", "")
sibu = Replace(sibu, "県", "")
If sibu <> "京都" Then
sibu = Replace(sibu, "都", "")
End If
Case "登録番号"
bangou = nukidasi
Case "会員番号"
kaiin_bangou = nukidasi
Case "郵便番号"
yubin = nukidas
Case "住所"
jyuusyo = nukidasi
Case "参加資格"
sanka_sikaku = nukidasi
End Select
Next i
End Sub
Public Function Search(ByVal rng As Range, ByVal keyWord As Variant, ByVal Whole As Boolean)
Dim r As Range
If Whole Then
For Each r In rng
If r.Value = keyWord Then
Set Search = r
Exit Function
End If
Next
Else
For Each r In rng
If InStr(r.Value, keyWord) > 0 Then
Set Search = r
Exit Function
End If
Next
End If
Set Search = Range("XFD1048576")←←エラー処理です。
End Function
