- ベストアンサー
語句のチェックマクロ
imogasiの回答
- imogasi
- ベストアンサー率27% (4737/17068)
質問がエクセルでないのは承知してますが、手軽なテストのためやってみた。 Ｉｎｓｔｒ関数を使うことを守ってやった。 ニキビ、対策、改善の３御をオール含むものＯＫ。 例データ Ａ１：Ｂ４ Ａ列が例文。Ｂ列が結果ＯＫかＮＯ。 例文 ニキビ対策の改善にこのメイクをどうぞ OK 腹痛対策改善にのメイクをどうぞ NO ニキビ対策の決定版にこのメイクをどうぞ NO ニキビ対策決定版。改善にこのメイクをどうぞ OK 標準モジュールに Sub test0() For i = 1 To 4 vl = Cells(i, "A") p = InStr(vl, "ニキビ") If p = 0 Then GoTo no p = InStr(vl, "対策") If p = 0 Then GoTo no p = InStr(vl, "改善") If p = 0 Then GoTo no Cells(i, "B") = "OK" GoTo nx no: Cells(i, "B") = "NO" nx: Next i End Sub 上記はＧｏＴｐ文があったりして、自慢じゃないが、気に食わなければ無視して。ロジックは何もむつかしくない。 条件が１つでも見つからなければ、脱落という考えで済む話。
関連するQ&A
- サイトタイトルに、指定した語句があれば○
下記のマクロは、指定範囲のURL先のソースに、 指定した語句があれば、○を付けるマクロです。 指定した語句をソース全て対象にせずに、 <title></title>のサイトタイトルの中にあれば、○を付けるというようにしたいです。 ちなみに、調べたいのは語句ではないですが、"【"というカッコです。 ・下記のマクロ URL先のソース全体の中に、指定した語句があれば○ ・希望のマクロ <title></title>（サイトタイトル）の中に、指定した語句があれば○ どの部分を修正、または追加すればできるようになりますか？ よろしくお願いいたします。 Sub 指定した語句() '!!!! [Microsoft XML v6.0] に参照設定すること Dim xHttp As IServerXMLHTTPRequest Dim myErr_Number As Long, myErr_Description As String Set xHttp = CreateObject("MSXML2.ServerXMLHTTP") Dim aCell As Range R = 1 For Each aCell In Selection.Columns(1).Cells '選択セルの1列目がURL Application.Goto aCell '対象URLの列にジャンプ表示 DoEvents sUrl = aCell.Value If sUrl <> "" Then xHttp.Open "GET", sUrl, True xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _ SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS ' SSL関係のエラーを無視 On Error Resume Next xHttp.send If xHttp.readyState <> 4 Then xHttp.waitForResponse 5 '5秒まってだめならタイムアウト End If If xHttp.readyState <> 4 Then Err.Raise 1004, , "タイムアウト" myErr_Number = Err.Number myErr_Description = Err.Description On Error GoTo 0 If myErr_Number = 0 Then sHtml = xHttp.responseText nRtn = InStr(sHtml, "指定した語句") If nRtn = 0 Then aCell.Offset(, 1).Value = "--" Else aCell.Offset(, 1).Value = "○" End If Else aCell.Offset(, 1).Value = myErr_Description ' エラー時はエラー内容を表示 End If DoEvents End If Next Set xHttp = Nothing End Sub
- ベストアンサー
- Visual Basic
- サイトタイトルの中に、指定した語句があれば○
下記は、URL先のソースの中に、 指定した語句があれば、○を付けるマクロです。 このURL先のソース、全てを対象にするのではなく、 <title></title>、つまりサイトタイトルの中に、 指定した語句があれば、○を付けるというように制限して調べたいです。 ・下記のマクロ URL先のソース全体の中に、指定した語句があれば○ ・希望のマクロ <title></title>（サイトタイトル）の中に、指定した語句があれば○ これは、どの部分を修正、追加すればできるようになるでしょうか？ また、「指定した語句」の他にも、「指定した語句２」「指定した語句３」、 つまり、<title></title>の中に、「●●」「▲▲」「■■」のどれかが含まれていたら、 隣のセルに○を付ける。という風にしたいです。 ソース全体で調べるなら、 nRtn = InStr(sHtml, "●●") + InStr(sHtml, "▲▲") + InStr(sHtml, "■■") で出来ると思うのですが、制限させて調べる場合は、 どのような記述になるでしょうか？ よろしくお願いいたします。 Sub 指定した語句() '!!!! [Microsoft XML v6.0] に参照設定すること Dim xHttp As IServerXMLHTTPRequest Dim myErr_Number As Long, myErr_Description As String Set xHttp = CreateObject("MSXML2.ServerXMLHTTP") Dim aCell As Range R = 1 For Each aCell In Selection.Columns(1).Cells '選択セルの1列目がURL Application.Goto aCell '対象URLの列にジャンプ表示 DoEvents sUrl = aCell.Value If sUrl <> "" Then xHttp.Open "GET", sUrl, True xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _ SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS ' SSL関係のエラーを無視 On Error Resume Next xHttp.send If xHttp.readyState <> 4 Then xHttp.waitForResponse 5 '5秒まってだめならタイムアウト End If If xHttp.readyState <> 4 Then Err.Raise 1004, , "タイムアウト" myErr_Number = Err.Number myErr_Description = Err.Description On Error GoTo 0 If myErr_Number = 0 Then sHtml = xHttp.responseText nRtn = InStr(sHtml, "指定した語句") If nRtn = 0 Then aCell.Offset(, 1).Value = "--" Else aCell.Offset(, 1).Value = "○" End If Else aCell.Offset(, 1).Value = myErr_Description ' エラー時はエラー内容を表示 End If DoEvents End If Next Set xHttp = Nothing End Sub
- ベストアンサー
- Visual Basic
- キーワードが全部あるのに、○が付かない
下記のマクロは、URL先のソースの中に、 「赤ちゃん」「妊婦」「ママ」「水」「ウォーター」 のどれかがあれば、隣に○を付けるというものです。 ですが、 https://www.andrea-pennington.com/ こちらのサイトを調べたところ、 キーワードが全部あるのに、○が付かず--でした。 マクロの記述がどこかおかしいでしょうか？ ソースの中に、どれかのキーワードがあれば、 ○が付くようにするには、どのような記述になるでしょうか？ Excel２０１６です。 よろしくお願いいたします。 Sub main() '!!!! [Microsoft XML v6.0] に参照設定すること Dim xHttp As IServerXMLHTTPRequest Dim myErr_Number As Long, myErr_Description As String Set xHttp = CreateObject("MSXML2.ServerXMLHTTP") Dim aCell As Range R = 1 For Each aCell In Selection.Columns(1).Cells '選択セルの1列目がURL Application.Goto aCell '対象URLの列にジャンプ表示 DoEvents sUrl = aCell.Value If sUrl <> "" Then xHttp.Open "GET", sUrl, True xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _ SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS ' SSL関係のエラーを無視 On Error Resume Next xHttp.send If xHttp.readyState <> 4 Then xHttp.waitForResponse 5 '5秒まってだめならタイムアウト End If If xHttp.readyState <> 4 Then Err.Raise 1004, , "タイムアウト" myErr_Number = Err.Number myErr_Description = Err.Description On Error GoTo 0 If myErr_Number = 0 Then sHtml = xHttp.responseText nRtn = InStr(sHtml, "赤ちゃん") + InStr(sHtml, "妊婦") + InStr(sHtml, "ママ") + InStr(sHtml, "水") + InStr(sHtml, "ウォーター") If nRtn = 0 Then aCell.Offset(, 1).Value = "--" Else aCell.Offset(, 1).Value = "○" End If Else aCell.Offset(, 1).Value = myErr_Description ' エラー時はエラー内容を表示 End If DoEvents End If Next Set xHttp = Nothing End Sub
- ベストアンサー
- Excel（エクセル）
- "【"が、Shift_JISのサイトで認識できない
下記のマクロは、指定範囲のURL先のソースに、 指定した語句があれば、○を付けるマクロです。 指定した語句をソース全て対象にせずに、 <title></title>のサイトタイトルの中に、"【"があれば○を付けるというようにしたいです。 （クォーテーションマーク抜きの【） https://okwave.jp/qa/q9899670.html こちらで先に質問をして回答をいただいたのが、 元のコードの一部を、 If sHtml Like "*<title>*" & "【" & "*</title>*" Then aCell.Offset(, 1).Value = "○" Else aCell.Offset(, 1).Value = "--" End If に変更するというものです。 しかし、これだとUTF-8のサイトは認識できますが、 Shift_JISのサイトでは認識できないようです。（【があるのに、○が付かない） UTF-8とShift_JISのサイト両方を認識して、 "【"が、<title></title>の中にあるものに○を付くようにするには、 どのようなマクロの記述になりますでしょうか？ よろしくお願いいたします。 Sub 指定した語句() '!!!! [Microsoft XML v6.0] に参照設定すること Dim xHttp As IServerXMLHTTPRequest Dim myErr_Number As Long, myErr_Description As String Set xHttp = CreateObject("MSXML2.ServerXMLHTTP") Dim aCell As Range R = 1 For Each aCell In Selection.Columns(1).Cells '選択セルの1列目がURL Application.Goto aCell '対象URLの列にジャンプ表示 DoEvents sUrl = aCell.Value If sUrl <> "" Then xHttp.Open "GET", sUrl, True xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _ SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS ' SSL関係のエラーを無視 On Error Resume Next xHttp.send If xHttp.readyState <> 4 Then xHttp.waitForResponse 5 '5秒まってだめならタイムアウト End If If xHttp.readyState <> 4 Then Err.Raise 1004, , "タイムアウト" myErr_Number = Err.Number myErr_Description = Err.Description On Error GoTo 0 If myErr_Number = 0 Then sHtml = xHttp.responseText nRtn = InStr(sHtml, "指定した語句") If nRtn = 0 Then aCell.Offset(, 1).Value = "--" Else aCell.Offset(, 1).Value = "○" End If Else aCell.Offset(, 1).Value = myErr_Description ' エラー時はエラー内容を表示 End If DoEvents End If Next Set xHttp = Nothing End Sub
- ベストアンサー
- Visual Basic
- A2の値がA1の値と同じ場合はB2にB1の値+1をして
A2の値がA1の値と同じ場合はB2にB1の値+1をして A2の値がA1の値と違う場合はB2に"1"を繰り返しさせて入力するように 以下としたのですが、A列の値がなくなる限り1が入力されるだけなのですが どうすれば、A列のセルに同じ値が続く場合連番とすることができるでしょうか。お願いします。 range("B1").value = 1 range("B2").select dim 番号 As varient 番号 = activecell.offset(-1, -1).value do until activecell.offset(0,-1).value = "" with activedell if offset(0, -1).value = 番号 then offset(0, 0).value = offset(-1, 0).value + 1 end if offset(0, 0).value = "1" offset(1, 0).select end with loop
- 締切済み
- Visual Basic
- A B C
A B C コード 商品 単価 1 チョコレート 100 2 キャンディー 50 3 ガム 80 4 スナック菓子 150 5 乳製品 170 上記表の下にデータを追加していきたいのですが、その際重複データの入力及びコピーもできないようにしたいと思います。 Private Sub CommandButton1_Click() Dim endrow As Long Dim i As Integer endrow = Range("商品").Columns(1).CurrentRegion.Rows.Count Range("商品").Rows(endrow + 1).Columns(1).Value = TextBox1.Value Range("商品").Rows(endrow + 1).Columns(2).Value = TextBox2.Value Range("商品").Rows(endrow + 1).Columns(3).Value = TextBox3.Value TextBox1.Value = Clear TextBox2.Value = Clear TextBox3.Value = Clear With Range("A2") For i = .CurrentRegion.Rows.Count To 1 Step -1 If .Offset(i, 0) = .Offset(i - 1, 0) Then .Offset(i, 0).EntireRow.Delete Next i End With End Sub すぐ上の行と同じ場合には入力ができませんが、それ以外での重複している場合の入力を回避する為の改善箇所をご教示の程お願い致します。(コードが同じで入力不可)
- 締切済み
- オフィス系ソフト
- 処理速度を速くする方法教えてください。
Private Sub CommandButton1_Click() Dim irow As Long Dim Celldata(1 To 6) As Double Dim ekimen(1 To 6) As String '高さ読込み If TextBox8.Value = "" Then MsgBox ("No.を入力") End End If If TextBox9.Value = "" Then MsgBox ("温度を入力") End End If If TextBox10.Value = "" Then MsgBox ("係数を入力") End End If Celldata(1) = TextBox1.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(2) = TextBox2.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(3) = TextBox3.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(4) = TextBox4.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(5) = TextBox5.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(6) = TextBox6.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value '入力と修正 Dim i As Long '最終行から試験Noが一致するものを探す For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(TextBox8.Value) Then Set myrange = Sheets("データ").Cells(i - 1, 1) '記入セルがoffset(1,x)になっているため、i-1にしています。 Exit For End If Next i 'Noが一致しない場合、最終行を記入セルに設定する。 If i = 5 Then Set myrange = Sheets("データ").Range("A65536").End(xlUp) End If 'ワークシートへの転記 With myrange .Offset(1, 0).Value = TextBox8.Value '----No. .Offset(1, 1).Value = Celldata(1) '----１計測 .Offset(1, 2).Value = Celldata(2) '----２計測 .Offset(1, 3).Value = Celldata(3) '----３ル計測 .Offset(1, 4).Value = Celldata(4) '----４計測 .Offset(1, 5).Value = Celldata(5) '----５計測 .Offset(1, 6).Value = Celldata(6) '----６計測 .Offset(1, 13).Value = TextBox1.Value '----１追加 .Offset(1, 14).Value = TextBox2.Value '----２追加 .Offset(1, 15).Value = TextBox3.Value '----３追加 .Offset(1, 16).Value = TextBox4.Value '----４追加 .Offset(1, 17).Value = TextBox5.Value '----５追加 .Offset(1, 18).Value = TextBox6.Value '----６追加 .Offset(1, 19).Value = TextBox7.Value '---温度 .Offset(1, 20).Value = TextBox11.Value '----１高さ .Offset(1, 21).Value = TextBox12.Value '----２高さ .Offset(1, 22).Value = TextBox13.Value '----３高さ .Offset(1, 23).Value = TextBox14.Value '----４高さ .Offset(1, 24).Value = TextBox15.Value '----５高さ .Offset(1, 25).Value = TextBox16.Value '----６高さ '入力ボックスのクリア TextBox1.Value = "" '----1セル TextBox2.Value = "" '----2セル TextBox3.Value = "" '----3セル TextBox4.Value = "" '----4セル TextBox5.Value = "" '----5セル TextBox6.Value = "" '----6セル TextBox7.Value = "" '---温度 TextBox11.Value = "" '----1セル TextBox12.Value = "" '----2セル TextBox13.Value = "" '----3セル TextBox14.Value = "" '----4セル TextBox15.Value = "" '----5セル TextBox16.Value = "" '----6セル End With 'lblComment.Caption = "ワークシートに転記しました！" End Sub Private Sub CommandButton2_Click() Dim i As Long '入力チェック If TextBox8.Value = "" Then MsgBox ("No.を入力") End End If If TextBox9.Value = "" Then MsgBox ("温度を入力") End End If If TextBox10.Value = "" Then MsgBox ("係数を入力") End End If For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(TextBox8.Value) Then Set myrange = Sheets("データ").Cells(i - 1, 1) '記入セルがoffset(1,x)になっているため、i-1にしています。 Exit For End If Next i '受付No.がない場合、終了します。 If i = 5 Then MsgBox ("No.が見つかりません") End End If '入力の処理と逆の処理を行います。 With myrange TextBox1.Value = .Offset(1, 13).Value '---１計測 TextBox2.Value = .Offset(1, 14).Value '---２計測 TextBox3.Value = .Offset(1, 15).Value '---３計測 TextBox4.Value = .Offset(1, 16).Value '---４計測 TextBox5.Value = .Offset(1, 17).Value '---５計測 TextBox6.Value = .Offset(1, 18).Value '---６計測 TextBox7.Value = .Offset(1, 19).Value '---温度 TextBox11.Value = .Offset(1, 20).Value '---１高さ TextBox12.Value = .Offset(1, 21).Value '---２高さ TextBox13.Value = .Offset(1, 22).Value '---３高さ TextBox14.Value = .Offset(1, 23).Value '---４高さ TextBox15.Value = .Offset(1, 24).Value '---５高さ TextBox16.Value = .Offset(1, 25).Value '---６高さ End With End Sub
- ベストアンサー
- その他MS Office製品
- Excel VBAフォーム 登録ボタンの作成方法
いつもお世話になっています。 初めて、Excelのフォームで入力画面を作りました。 複数の項目があって、それを最後に[登録]ボタンをクリックで 表に入れたいのですが、一度にまとめて実行する方法が分かりません。 アドバイスよろしくお願いいたします。 Private Sub cmd_1() Dim i As String If man.Value = True Then ActiveCell = man.Caption End If If woman.Value = True Then ActiveCell = woman.Caption End If ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_2() Dim i As String If man.Value = True Then ActiveCell = Yes.Caption End If If woman.Value = True Then ActiveCell = No.Caption End If ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_downlist() Dim ListNo As Long ListNo = group.ListIndex ActiveCell.Value = group.List(ListNo, i) ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_comment() ActiveCell = comment.Text ActiveCell.Offset(1, -3).Select End Sub
- 締切済み
- Visual Basic
- VBAについて
以下のプログラムは、1年間の価格合計を求めるプログラムです。 これを実行するとうまくいくこともありますが、エラーが起きることもあります。 どうやら下記コードが原因のようなのですが、間違いがわかりません。 Target.Offset(0, 1).Value = run * (13 - month) どこが間違っているのでしょうか。 また最終的に、A行かB行のどちらかが更新されたときにこのプログラムを 実行させたいのですが、方法がわかりません。 無知な質問ではありますが、どなたか教えてください。 --------------------------------------------------------- Private Sub Worksheet_Change(ByVal Target As Range) Dim month As Integer Dim run As Integer If Intersect(Target, Range("A25:A35")) Is Nothing Then Exit Sub Else If Target.Offset(0, -2).Value <> "" Then month = Target.Offset(0, -2).Value month = month - 3 If month = -2 Then month = 10 ElseIf month = -1 Then month = 11 ElseIf month = 0 Then month = 12 End If run = Target.Offset(0, 0).Value Target.Offset(0, 1).Value = run * (13 - month) End If End If End Sub
- 締切済み
- Visual Basic
- タイムスタンプを挿入して、時間の経過に合わせて色
Q列に同じ行のA列に文字が入ると、タイムスタンプを挿入して、時間の経過と共に、720時間かけて白から赤にグラデーション変化する。 上記のVBAを行いたいのですが、オーバーフローエラーが発生します。どの様に修正すれば良いでしょうか？ Private Sub Worksheet_Change(ByVal Target As Range) Dim currentDate As Date Dim startTime As Date Dim endTime As Date If Target.Column <> 1 Or Target.Cells.Count > 1 Then Exit Sub If Target.Offset(0, 15).Value = "" And Target.Value <> "" Then startTime = Now() Target.Offset(0, 15).Value = startTime ElseIf Target.Offset(0, 15).Value <> "" And Target.Value = "" Then endTime = Now() Target.Offset(0, 15).Value = "" End If currentDate = Now() If Target.Offset(0, 15).Value <> "" Then Target.Offset(0, 16).Interior.Color = GradientColor(Target.Offset(0, 15).Value, currentDate, startTime, 720) Else Target.Offset(0, 16).Interior.Color = RGB(255, 255, 255) End If End Sub Function GradientColor(ByVal timeStart As Date, ByVal timeEnd As Date, ByVal startTime As Date, ByVal duration As Integer) As Long Dim secondsElapsed As Long Dim fractionTimeElapsed As Double secondsElapsed = DateDiff("s", startTime, timeEnd) ➡︎ fractionTimeElapsed = secondsElapsed / (duration * 3600) fractionTimeElapsed = IIf(fractionTimeElapsed > 1, 1, fractionTimeElapsed) GradientColor = RGB(255 * (1 - fractionTimeElapsed), 255 * fractionTimeElapsed, 255 * fractionTimeElapsed) End Function
- ベストアンサー
- Visual Basic
補足
>質問がエクセルでないのは承知してますが、手軽なテストのためやってみた。 EXCELでマクロを動かしています。 カテゴリーは、EXCELの方が良かったでしょうか？ マクロをやってみましたが、NOが４つ表示されました。 URLのソースの中に、指定した語句がすべてある場合に◯が付く。 という形にしたいです。