- ベストアンサー
エクセルでURLに特定文字が含まれるか調べる方法
DOUGLAS_の回答
- DOUGLAS_
- ベストアンサー率74% (397/534)
DOUGLAS_ です。 前回答を書いてから、いろいろと調査しましたが、何となく「フリーズ」の原因が見えてきましたので、全面的にコードを書き直してみました。 したがって「回答No.6」はスルーなさってください。 下記のコードを試行していただき、なおも、フリーズするようでしたら、その旨、お知らせください。 Sub KeyWord_Search() Dim objHTTP As Object Dim i As Long Const strKW As String = "news" Set objHTTP = CreateObject("Msxml2.ServerXMLHTTP.6.0") With objHTTP 'タイムアウトを設定する場合は、下の行頭の「'」を削除してください。 ' .setTimeouts 4000, 500, 500, 3000 For i = 2 To Range("A1").End(xlDown).Row Cells(i, 2).Select If Cells(i, 2) = "" Then .Open "GET", Cells(i, 1).Value, False On Error Resume Next .Send Select Case .Status Case 200 Cells(i, 2).Value = " なし" If InStr(1, .ResponseText, strKW, 1) > 0 Then Cells(i, 2).Value = " あり" Case 404 Cells(i, 2).Value = " 不正なＵＲＬ" Case Else Cells(i, 2).Value = " 問題あり" End Select .Abort End If If Err.Number <> 0 Then Cells(i, 2).Value = Err.Description If Err.Number = -2147483638 Then Cells(i, 2).Value = "タイムアウト" On Error GoTo 0 Next End With Set objHTTP = Nothing End Sub
関連するQ&A
- エクセルのマクロについて
Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "ア") = 0 Then If InStr(.Cells(i, "D"), "ア(半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub このエクセルマクロはC列に「ア」があって、D列に「ア(半角)」の文字がない場合はメッセージというマクロなのですが、このマクロをア～ンまで同じ作業をしたいのですが、ひとまとめにマクロを組む事はできるのでしょうか？できる場合どのようにすれば良いでしょうか? 下記のようにして見たのですができませんでした。 Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "[ア-ン]") = 0 Then If InStr(.Cells(i, "D"), "[ア-ン](半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub
- 締切済み
- オフィス系ソフト
- エクセル マクロ 抽出
教えてください。 ○と記入されたセルを参照して、一つ上のセル・A列にある同じ行のセル・ 9行目にある同じ列のセルを抽出しようとしています。 下記の通り入力すると 行数＝値.Rowでエラーが出たしまいました。 試行錯誤頑張りましたが解決できそうにありませんのでお力を貸して頂けないでしょうか。 Sub 抽出() Dim i, 行数, 列数 As Long Dim 値 As Range i = 0 行数 = 値.Row 列数 = 値.Column For Each 値 In Sheets("sheet1").Range("C12:R171") If 値.Value = "○" Then i = i + 1 With Sheets("sheet2") .Cells(i, 3).Value = Sheets("sheet1").Cells(行数, 1).Value .Cells(i, 4).Value = Sheets("sheet1").Cells(9, 列数).Value .Cells(i, 5).Value = 値.Offset(-1, 0).Value End With End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- 特定の文字以外を入力すると別シートに表記する方法
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim StrRow As Long Dim TgtCol As Long Dim MaxRow As Long Dim ChgRow As Long Dim PutSh1 As Worksheet Dim PutSh2 As Worksheet Dim PutSh3 As Worksheet Dim PutCol As Long Dim PutRow As Long Dim ChgRng1 As Range Dim ChgRng2 As Range Dim ChgRng3 As Range StrRow = 5 MaxRow = 35 If Target.Count > 1 Then Exit Sub If Target.Value = "" Then Exit Sub Set PutSh1 = ThisWorkbook.Sheets("Sheet2") Set PutSh2 = ThisWorkbook.Sheets("Sheet3") Set PutSh3 = ThisWorkbook.Sheets("Sheet4") With ThisWorkbook.Sheets("Sheet1") Set ChgRng1 = Range(.Cells(StrRow, 3), .Cells(MaxRow, 3)) 'C列 Set ChgRng2 = Range(.Cells(StrRow, 5), .Cells(MaxRow, 5)) 'E列 Set ChgRng3 = Range(.Cells(StrRow, 7), .Cells(MaxRow, 7)) 'G列 End With ChgRow = Target.Row If Not Intersect(Target, ChgRng1) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh1, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng2) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh2, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng3) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh3, ChgRow, Target.Value End If End Sub 以前質問させて頂いた内容で追加の質問です。 Sheet1の指定したセルに「ー（ハイフン）」の文字がある時は、Sheet2〜4に転送（表記）しない方法を追加する場合はどの様にすれば宜しいでしょうか？
- ベストアンサー
- Excel（エクセル）
- ２つのVBAを組み合わせる方法
お世話になります、２つのVBAを組み合わせる方法で迷っています。 １つ目が Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True End Sub です。 ２つめが Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = True If Intersect(Target, Range("R8:R38")) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End Sub です。２つのPrivate Sub Worksheet_Change(ByVal Target As Range)イベントのVBAですが、どのようにして組み合わせれば良いのでしょうか？
- ベストアンサー
- Excel（エクセル）
- 下記のマクロをもっと早くするには？
下記のマクロは、 A列にあるURLがSSL化（https）されているかを調べるものです。 このマクロを動かすと、大体３秒に１つのURLを調べるくらいの早さです。 もっと早く調べられるようにするには、どのような記述にすればできるでしょうか？ また、エクセルの他の設定で、マクロを早くできたりしますか？ よろしくお願いいたします。 Sub SSL() Dim objHttp As Object Dim nURL As String Dim strURL As String Dim i As Long, f As String, l As String Dim Lastrow As Long, getLine As Long Set objHttp = CreateObject("WinHttp.WinHttpRequest.5.1") On Error GoTo ErrHandler 'A1から getLine = Cells(Rows.Count, 2).End(xlUp).Row Lastrow = Cells(Rows.Count, 1).End(xlUp).Row If getLine = Lastrow Then MsgBox "既に終わっているか、データがないです。", vbExclamation: Exit Sub If getLine < Lastrow And Cells(1, 2).Value <> "" Then getLine = getLine + 1 Else getLine = 1 '最初の行が1行目からの場合 End If For i = getLine To Lastrow strURL = LCase(Trim(Cells(i, 1).Value)) 'A列の登録URL strURL = Replace(strURL, "https:", "http:") If strURL Like "http*" Then objHttp.Open "GET", strURL, False objHttp.send DoEvents 'ESC割り込み可能にする With objHttp If .Status = 200 Then nURL = .Option(1) 'WinHttpRequestOption_URL f = Mid(strURL, 1, InStr(strURL, "://")) l = Mid(nURL, 1, InStr(nURL, "://")) If nURL = "" Then Cells(i, 2).Value = "no URL" ElseIf nURL <> "" Then If LCase(f) = LCase(l) Then Cells(i, 2).Value = "non SSL" Else Cells(i, 2).Value = "https" End If End If Else Cells(i, 2).Value = "Err:" & .Status End If End With End If Endline: nURL = "" strURL = "" Next i MsgBox "Finished" Exit Sub ErrHandler: If Err() <> 0 Then Cells(i, 2).Value = Err.Number 'マイナスになるのは外部エラー GoTo Endline End If End Sub
- 締切済み
- Visual Basic
- エクセルマクロ 特定の文字列を含む行のみを残す （マクロ修正）
以下のマクロは、EXCEL２００３で 「特定の文字列が含まれている列を削除する」動作をするマクロです Sub Macro1() Const col As String = "A" '文字列が入力されている列 Dim idx As Long Dim keyWord keyWord = Application.InputBox("削除対象の文字列は？", Type:=2) If TypeName(keyWord) <> "Boolean" And Len(keyWord) > 0 Then For idx = Cells(65536, col).End(xlUp).Row To 1 Step -1 If InStr(Cells(idx, col).Value, keyWord) > 0 Then ' If Application.CountIf(Rows(idx), "*" & keyWord & "*") > 0 Then Rows(idx).Delete End If Next idx End If End Sub このマクロを、 「特定の文字列が含まれている行のみを残し、それ以外を削除する」 というマクロに変更したいと思っています。 是非ご回答お願いいたします。
- ベストアンサー
- オフィス系ソフト
- 文字変換マクロについて
数値を文字列に変換するマクロで、行数や列数が増えても対応できるようにしたいです。 （並びは…数値 スペース 文字列）どなたか教えてください。 よろしくお願いします。 Sub 文字() Dim i As Long For i = 1 To Range("A1").End(xlDown).Row Cells(i, "C") = Cells(i, "A") With Cells(i, "C") .NumberFormatLocal = "@" .Value = StrConv(Cells(i, "C").Value, vbNarrow) .Value = Format(Cells(i, "C").Value, "'00") End With Next i End Sub
- ベストアンサー
- Excel（エクセル）
- エクセルマクロで特定の範囲内の検索
A10からA100までのセルを上から順に調べて、セルにAという文字が入力されているときに、その隣にBという文字を入力するマクロを下記のように作りました。 「セルにAという文字が入力されているとき」という条件に加え、「検索しているセルから上の9個のセル（cells(i-9,1)からcells(i-1,1)まで）にAという文字が入力されていない」という条件を加えたいのです。 Sub 検索() Dim i As Integer For i = 10 To 100 If Cells(i, 1).Value = "A" Then Cells(i, 2).value = "B" End If Next i End Sub つまり If Cells(i, 1).Value = "A" Then の部分を If Cells(i, 1).Value = "A" かつ Range(cells(i-9,1),cells(i-1,1))にAが入力されていない Then という形にしたいのですが、表現の仕方がわかりません。 ご教示よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルのマクロについて
下記は、A列3行の7文字目～10文字と B列5行～文字のある最後の行までの範囲の左から1文字目～4文字 に相違がある場合 MsgBox i ＆ “行目” を出す。 というマクロなのですが、『B列5行～文字のある最後の行までの範囲』の中でも『空白のセルに関してはMsgBox不要』というふうに付加えたいのですがどのようにすればよいでしょうか。 Sub Macro1() Dim i As Long Dim sOrgText As String Dim ltotal As Long With ActiveSheet sOrgText = Mid(.Cells(3, 1), 7, 4) ltotal = .Cells(65536, 2).End(xlUp).Row For i = 5 To ltotal If Not Mid(.Cells(i, 2), 1, 4) = sOrgText Then MsgBox i & "行目" End If Next i End With End Sub
- ベストアンサー
- SE・インフラ・Webエンジニア
- エクセルマクロ 複数特定文字を含む行以外の削除
M列にある特定の文字が含む行以外のものを削除するマクロを教えて下さい。 現在ネット検索で見つかったマクロを使用しています 【現在使用中のマクロ】 Sub Sample1() Dim i As Long For i = Cells(Rows.Count, "M").End(xlUp).Row To 2 Step -1 If InStr(Cells(i, "M"), "検索したい文字") = 0 Then Rows(i).Delete End If Next i End Sub これだと検索したい文字が1つしか利用できません。 「検索したい文字列1」または「検索したい文字列2」を含まない行を削除したいのですが どのようにマクロを組めばよいのでしょうか？ こちらまったくの初心者です。 上記の書式にはこだわりませんので、わかる方教えて下さい。
- ベストアンサー
- オフィス系ソフト
お礼
前回のテストでフリーズしたものを含め、海外URL3281件をまとめて一度に処理しても今回のコード（No.7）ではフリーズしませんでした。 今回のコードの凄いところは、問題URLで処理が止まっても（問題部分のセルを指し示して一時中断になるため）対処をすれば処理を再開できることです。 以前のようにエクセルを再起動して処理を一からやり直す心配がありません。 すごいと思いました。ここまで親切に対応して下さって誠にありがとうございます。 ご提示されている情報源も専門知識ばかりで、予備知識があったとしても解読が決して簡単ではなかったと思います。 本当にありがとうございました。 タイムアウト設定に関しまして タイムアウト設定（「'」を削除）をすると（タイムアウトを設定しなければ正常に処理されていたのに）タイムアウトになるURLが多くなりすぎましたので、タイムアウトを設定しないまま使用する方がよいと思いました。 また、エラーの詳細が詳しくわかった方が（私の場合は）「正常に処理できているかどうか」という不安が減るため、 ---------- Case 404 Cells(i, 2).Value = " 不正なＵＲＬ" ---------- のところを、 ---------- Case 100 Cells(i, 2).Value = "100" Case 101 Cells(i, 2).Value = "101" Case 201 Cells(i, 2).Value = "201" Case 202 Cells(i, 2).Value = "202" Case 203 Cells(i, 2).Value = "203" Case 204 Cells(i, 2).Value = "204" Case 205 Cells(i, 2).Value = "205" Case 206 Cells(i, 2).Value = "206" Case 300 Cells(i, 2).Value = "300" Case 301 Cells(i, 2).Value = "301" Case 302 Cells(i, 2).Value = "302" Case 303 Cells(i, 2).Value = "303" Case 304 Cells(i, 2).Value = "304" Case 305 Cells(i, 2).Value = "305" Case 307 Cells(i, 2).Value = "307" Case 400 Cells(i, 2).Value = "400" Case 401 Cells(i, 2).Value = "401" Case 403 Cells(i, 2).Value = "403" Case 404 Cells(i, 2).Value = "404" Case 405 Cells(i, 2).Value = "405" Case 406 Cells(i, 2).Value = "406" Case 407 Cells(i, 2).Value = "407" Case 408 Cells(i, 2).Value = "408" Case 409 Cells(i, 2).Value = "409" Case 410 Cells(i, 2).Value = "410" Case 411 Cells(i, 2).Value = "411" Case 412 Cells(i, 2).Value = "412" Case 413 Cells(i, 2).Value = "413" Case 414 Cells(i, 2).Value = "414" Case 415 Cells(i, 2).Value = "415" Case 416 Cells(i, 2).Value = "416" Case 417 Cells(i, 2).Value = "417" Case 500 Cells(i, 2).Value = "500" Case 501 Cells(i, 2).Value = "501" Case 502 Cells(i, 2).Value = "502" Case 503 Cells(i, 2).Value = "503" Case 504 Cells(i, 2).Value = "504" Case 505 Cells(i, 2).Value = "505" ---------- このように変更してみました。 一点だけ問題があります。「A1セルを処理しないこと」です。 A2セルからA列の最終行まで処理を行いますが、なぜかA1セルのみスルーしてしまうことです。 ここまで完璧なコードですのでこれは些細な問題で、使い方を工夫（A1セルはスペースでも入力しておき、A2セルから下へ処理するURLを貼り付け）すればよい話です。 しかし、完璧なコードであるだけに、より完璧であった方がやはり嬉しいです。 もし、ほんの一部分を変更するだけでA1セルからの処理を実現できるなら、最後にぜひお願いします。 もちろんかなり手間がかかるような内容でしたら、現状のままで全く問題ありません。 よろしくお願いいたします。