カテゴリー: あれこれ

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Application.ScreenUpdating = True
End Sub

Range("B6:G15").FormatConditions.Add(Type:=xlExpression, Formula1:="=$G6>=85").Interior.Color = rgbPowderBlue

Range("B6:G15").FormatConditions.Add(Type:=xlExpression, Formula1:="=AND(CELL("ROW")=ROW(), cell("COL")=COLUMN())").Interior.Color = rgbPowderBlue

 'ハイライトしたい場所を Formula1:= の右側に "" で囲んで入力してください
       Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=CELL(""ROW"")=ROW()"

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

 MsgBox kensakukekka

 MsgBox kensakukekka & kensakukekka.Row

kensakukekka = Search(Hani, "リンゴ", True)

Set kensakukekka = Search(Hani, "リンゴ", True)

 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 DateValue(sousin)　<　DateValue("2030/01/22") Then             'ハワイ支部会員先行受付
          If Not(syubetu = "会員" And InStr(sibu, "ハワイ") > 0） Then
                objmailItem.Move objFolder_kikangai
          End If
End If

Function SendSakuraMail(kenmei As String, mozi As String, address As String) As Boolean

    Dim objCDO As New CDO.Message

    On Error GoTo Errlabel    'エラー処理

    With objCDO

        With .Configuration.Fields
            .Item(cdoSMTPServer) = "****.sakura.ne.jp"
            .Item(cdoSendUsingMethod) = cdoSendUsingPort
            .Item(cdoSMTPServerPort) = 587                          '送信サーバーのポート番号
            .Item(cdoSMTPConnectionTimeout) = 15                    'タイムアウト
            .Item(cdoSMTPAuthenticate) = cdoBasic                   'SMTP認証
            .Item(cdoSMTPUseSSL) = False                            'SSL
            .Item(cdoSendUserName) = "--------@****.sakura.ne.jp"
            .Item(cdoSendPassword) = "?????????????????"
            .Item(cdoLanguageCode) = CdoCharset.cdoShift_JIS        '文字セット指定
            .Update '設定を更新
        End With
        With .Fields
            '重要度、通常は以下のどちらかで良いでしょう
            .Item("urn:schemas:mailheader:X-Priority") = 1
            .Item("urn:schemas:mailheader:X-MsMail-Priority") = "High"
            .Update '設定を更新
        End With
        .MDNRequested = False                   '開封確認
        .MimeFormatted = True                   'MIMEを使って書式設定
        .From = "------------@-----------.jp"
        .To = address                           '関数の引数で受け取った送信先
        .CC = ""
        .Subject = kenmei                       '関数の引数で受け取った件名
        .TextBody = mozi                        '関数の引数で受け取ったメール本文
        .Send                                   '送信
    End With
    Set objCDO = Nothing
    SendSakuraMail = True
    Exit Function
Errlabel:
  SendSakuraMail = False      '何かしらのエラーの場合はfasleをreturanする

End Function