カテゴリー: エクセル

投稿日:

条件付き書式をVBAで設定　エクセル　VBA　アクティブセルの強調

アクティブセル（選択されているセル）を強調するのに，シートの条件付き書式の設定で次のようにしてまし
た。

　　リボンホーム

　　設定する範囲の選択

　　「条件付き書式」をクリック

　　「新しいルール」をクリック

　　「数式を使用して，書式設定すセルを決定」をクリック

　　「次の数式を満たす場合に値を書式設定」のところに次の数式を入れる

　　=AND(CELL(“ROW”)=ROW(), cell(“COL”)=COLUMN())

　　「書式設定」クリック→→「塗りつぶし」→→「色を選択」

　　VBAの開発画面で，該当するシートに

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

　　を記入。

こうすることで，選択したセル（カーソルのあるセル）に設定した色をつけるいことができます。
この条件付き書式を　VBA　でも設定できることは，前から知っていましたが，やってみることに。
ある諸兄のHPを参考に，

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

のようにして，Formula1:=　以下に条件式を書けばいいと，記載がありました。そこで，

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

のように，先ほどのシートで使った数式をいれてみました。しかし，これがことごとくエラーになります。
エラー解消すべくいろいろやってみましたがだめでしたので，困ったときのHPということで，あれこれ検索
して，ヒントになる　HP　を発見。 ここのHPの条件式の書き方が参考になりました。
ここでは，

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

のよう記述がありました。

CELL(“ROW”)→→CELL(“”ROW””)

そういえば，VBA　で出たエラーを見ると，「区切りがどおうのこうの・・・・」というものだったようで
す。区切りが判別できないエラーだったんですね。”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

これをWROKBOOKに書き込むことで，送信表のシートで選択セルの強調ができるようになりました。

ちなみに，行だけを強調するには，
「=AND(CELL(“”ROW””)=ROW(), CELL(“”COL””)=COLUMN())」→→「=CELL(“”ROW””)=ROW()」

また，列だけを強調するには，
「=AND(CELL(“”ROW””)=ROW(), CELL(“”COL””)=COLUMN())」→→「=CELL(“”COL””)=COLUMN()」

行も列も強調するには，
「=AND(CELL(“”ROW””)=ROW(), CELL(“”COL””)=COLUMN())」
　　　　↓
「=OR(CELL(“”ROW””)=ROW(), CELL(“”COL””)=COLUMN())」

のようにすればいいようです。

投稿日:

エクセル　VBA　Rangeの落とし穴

仕事関連のお手伝いで，使うエクセルVBAをいじってます。久しぶりに，ドツボにはまりました。ある方のHP
を参考にした（丸ぱくり）サーチのプロシャージャでのことです。

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.Row　は，検索結果の入っている，行番号を返すはずなのですが，エラーになり
ます。訳が分かりませんでしたので，お助け掲示板かなと思っていたのですが，ふと気がつきました。
気がつくまで，半日無駄にしました。原因は，分かってみると，簡単なのですが，呼び出しのサブルーチン
に使っていた，

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

が違っていたのです。Range　の設定には，　Set　をつけてやる必要があったのです。

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

のように，Set　を入れると無事思った動作になりました。　Range　を扱う時は，Set　を入れることを失念
したための大ポカでした。
半分？動いたので，大丈夫と思っていたのが大間違いでしたが，たちが悪いですね。エラーなら全部エラー
になればいいのになんて思いました。

投稿日:

エクセルーVBAー「何もしない」命令

仕事のお手伝いで使うＶＢＡのプロシャージャの修正をしています。
変更があったときになるべく修正をしなくていいようなものを模索しています。また，同時に，後で見たとき
に何をやってるのか分かるような視認生を有効にできるように心がけていますが，両立させるのは，結構手間
がかかります。

今まで，先行受付については，期間については，手動で加減していましたが，期間についても，プロシャージ
ャに入れることにしました。
下記のようなものを考えました。

 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

該当する条件を考えて，それに　NOT　をつけて，（該当しない条件にする）この方が，いいかもですね。

投稿日:

CDOによるメール送信ーエクセル　VBA　ＩＰロック

CDOを使うと，エクセルVBAから，OUTLOOK等を経由しなくてもメールが送れるということを知りました。
そこで，下記のサイトを参考（コピペ）にして，トライしてみることにしました。

下記のコピペのプロシャージャyの必要な部分を自分の環境に合わせてやってみましたが，メールが送れま
せんでした。CDOそのものが使えないのかとも思いましたが，２０２４年現在お使いの方いるということで設
の定間違いだろうと検討をつけてあれこれやりました。

VBAを使ってスクレイピングの結果をメール送信する（さくらのレンタルサーバー使用)

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

結果，無事，メールを送ることができました。
原因は，送信メールアドレスのドメインを，初期のものにしていませんでした。

　　　　　誤　*********.jp——-取得独自ドメイン
　　　　　正　***.sakura.ne.jp—初期ドメイン

といっても，無事送れたのは，１回だけです。頭を悩ましましたが，１時間後にまた送信成功。
おかしいなと思い，あれこれ検索してみると，下記のような記事を見つけました。

特定の時間に一定時間メールの送受信ができない

この記事の中に，

さくらのレンタルサーバではセキュリティ対策により、パスワード認証を続けて失敗した、
あるいはその他、攻撃とみなされるようなアクセスがあった場合に、接続元のグローバル
IPアドレスから以下のプロトコルでのサーバへの接続を一定時間制限させていただくことが
あります。

というような記述がありました。その症状として，

・毎週、休暇明けの月曜日8:00～9:00にメールの送受信ができない。
・断続的に1時間程度メールの送受信ができない時間が発生する。

ということで，これに当てはまるのかなと納得いたしました。

結論として，何度も間違た設定で接続したので，ＩＰ　ロックがかかってしまったと，考えるのがいいようです。

＝＝＝追記＝＝＝
サクラのレンタルサーバーでの動作確認をする過程で，ｇｍａｉｌ．ｙａｈｏｏ　のメールでも試しました
が，どちらもだめでした。ｙａｈｏｏ　については，すでに，二段階認証になっていたので，だめかなと思
ってました。ｇｍａｉｌ　については，わずかな期待もっていましたが，ｇｍａｉｌ　については，
「安全性の低いアプリ」からの接続は，順次廃止されるようで，ｇｍａｉｌ　のアカウント内で作成
した「アプリパスワード」が必要なようです。

投稿日:

エクセル　VBA　メール送信の記録をエクセルに保存

お仕事のお手伝いの関係で，ＶＢＡをいじってます。エクセルを使って，催しの受付記録のおてつだいです。
いままでは，何のチェックもなく送信終了すれば，送信済　の記入をエクセルにしてました。ただ，これだ
と，途中で送信をやめたり，そうしんできずに送信トレイに残ってて，送信済の記録みなってしまいます。
自分だけは解決できそうにないので，ＯＵＴＬＯＯＫ研究所に投稿をしてみました。結果，ちょっと時間
がかかったようですが，すばらしい回答をいただきました。その方法は，送信済みのメールが，送信済み
トレイに移動するときに，発生するイベントを利用するというものでした。クリックイベントとかは，普通
に使ってましたが，ＯＵＴＬＯＯＫのイベントについては，分かりませんでした。早速，自分の環境にて，
試してみました。見事に動きました。

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

メールを送信する前に，送信するメールitem，記録する列番号，行番号をいれて，

AddTrackInfo（メールitem，記録する列番号，記録する行番号）

を呼び出します。そうすると，送信するメールのプロパティに記録する　列・行　の番号が付加されて
送信済みフォルダーに移動されます。そうすると，送信済みイベントが発生し，メールのプロパティ
から，行・列番号が付加されていると，エクセルに記録されることになるようです。
と，おおまかな，手順は理解しましたが，細かいところで，理解が進んでないので，目下，プロシャージャ
の解析中です。

投稿日:

エクセルVBA－エラー処理

プログラムを作り始めて何年になるでしょうかね。就職して，２年目からですから，結構な年月になります。
当時は,PCのはじめで，やりたいことのほとんどは，BASIC　と呼ばれる言語で，自作しないといけませんでし
た。そのうち，MS-DOS上で動くマルチプランやらwindoesで動くロータス１２３等がでてきました。確か，
ロータス１２３は，当時６８０００円か７８０００円ぐらいしたと記憶していました。おまけに，１２３は，
プロテクトがかけられていて，バックアップができませんでした。その後，コピーツール等がでてきて，バッ
クアップはできるようになりました。
それにしても，高かったです。ただ，自分でもプログラムを作ってましたので，それが作成されるまでの労力
を考えると，決して高くないと思ってました。素人の自分が作るプログラムと，その高いプログラムはどこが
ちがうのでしょうか。もちろん完成度もあるのですが，素人とプロでは，エラー処理が格段に違います。プロ
は，考えるすべてのエラー処理をしていますが，素人の私が作るものは，動けばいい，というレベルのもので
す。
ただ，作るにあたっては，最低限の処理が必要になります。たとえは今，仕事のお手伝い関係で自作している
エクセルvbaのサーチのプロシャージャ（プログラム）でも，目的の項目がサーチできなかった時は，どうす
るかの処理ぐらいは必要になってきます。
そんな訳でエラーの時に，

ＸＦＤ１０４８５７６

を返すものを作りました。この数字はなにかというと，
エクセルの表の最右列・最下段のセルということで，一番端っこのセルの番地を表す数字です。なぜ，この
この数字を使ったのかと言うと，昔ＢＡＳＩＣでプログラムをくんでいた時のなごりで，エラー処理に普段
出てこない，９９９９とか言う数字を使った名残です。（確か何年構えに２０００年問題ということで，
話題になりましたね。これも。エラー処理に１９９９という数字を使っていて，ためですね）
ところが，デバックしているときにまたまた，はまりました。わざとエラーを起こしても，ＸＦＤが返って
こないのです。返ってくるのは，１６３８４という数字が返ってきてしまいます。あれこれやりましたが，
肝心なこと忘れてました。使ったのは，Column　というプロパティですが，当たり前ですが，このプロパテ
ィは，数字を返すものでした。ネット検索で，

Split(Columns(列番号).Address, “$”)(2)

のようにやって，やっと目的のＸＦＤが返ってきました。長かったです。

下記がＸＦＤ１０４８５７６を返す，関数です，といってもぱくりです。

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

デバックに使ったプロシャージャです。

MsgBox Split(Columns(Search(rng, "******", True).Column).Address, "$")(2)
投稿日:

エクセル（関数　文字列の分割　空白区切り）

手伝いでやっている仕事関連で，エクセルをいじっています。疑問点があったので，「教えてGoo」の記事を
みていました。
すると，空白区切りの文字列を分割するには，どうすればいいのか，という，投稿
がありました。

写真のように，一つのセルに入っているデータを空白を区切りに，セルごとに分割したいとのことでした。
VBAを使って，

　　〇空白の数を数える。
　　〇空白が先頭から何番目にあるか調べる。
　　〇先頭から，最初の空白の前までの文字を切り出す。
　　〇２番目と３番目の空白の間にある文字を切り出す。
　　〇３番目を４番目の空白の間にある文字を切り出す。
　　〇４番目と５番目の空白の間にある文字を切り出す。
　　〇５番目の空白以降の文字をきりだす。

というようなことをやればできそうに思えましたが，なんと，この作業を１行の関数でおこなってる諸兄がい
ました。

　　=TRIM(MID(SUBSTITUTE($B2, ” “, REPT(” “,LEN($B2))),(COLUMN(A1)-1)*LEN($B2)+1, LEN($B2)))

この１行の関数をC2のセルにいれて，Hのセルまでドラグしてコピーすると分割ができてしまうのです。

何をやっているのか，関数をしげしげと並べて，自分なりに解釈してみました。

　REPT(“　”,LEN($B２))

で，元々文字列分の空白を作ります。
その後，一文字の空白と，文字列長分の空白を入れ替えます。

SUBSTITUTE($B2, ” “, REPT(” “,LEN($B2)))

この入れ替えた，文字列の先頭から，文字をきりだします。

MID(SUBSTITUTE($B2, ” “, REPT(” “,LEN($B2))),(COLUMN(A1)-1)*LEN($B2)+1, LEN($B2))

切り出す際に，

(COLUMN(A1)-1)*LEN($B2)+1

で，どこから切り出すかを決めています。うまい具合に，COLUMN(A1)のA1の部分は，コピーするたびに，

A1→B2→C2→D3→E5

のように，エクセルの方で，相対的に移動してくれます。結果，切り出し開始位置が，文字長分だけずれてくれます。
結果

COLUMN(A1)→１
COLUMN(B1)→２
COLUMN(C1)→３
COLUMN(D1)→４

のようにCOLUMNの値が増えていきますので，切り出し開始位置が文字長だけずれていきますので，一番目，２番目
と切り出すことができるようです。

最後に

TRIM(　）

で，余分な空白を削除すれば，完成です。

写真は，空白を「*」に置き換えて表示しています。

しかし，頭の良い方は，考え方がちがうのですね。余分な空白をいれて，一気に切り出して，余分なものを取
り除くことで目的をはたしているのですごいと思いました。