URLからタイトルを取得したい！ -エクセルのＡ列にはURLがずらっとあり-

エクセルでURLからタイトルのみを抽出する方法

URLからタイトルを抽出するマクロについて教えて下さい。忍者ブログの記事タイトルをURLから抽出しようとしたのですが文字化けしてしまい全く分かりません。他のサイトやブログだと普通に抽出出来るのですが・・・文字コード？か何かだと思うのですが、原因が分かりません。ちなみに以下のマクロは、ネット上で検索して見つけたものをそのままコピーして使用しています。－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A3") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send buf = StrConv(Http.ResponseBody, vbUnicode) 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－宜しくお願い致します。

エクセルでマクロの進行状況を表示あるには

下記のマクロはURLからタイトルを抽出するものなのですが件数が何千件とあり、進行状況が分かれば便利かなと思います。表示方法はどのような形でも構わないのですが、ご教授願います。色々調べたのですがうまくいかず困っております。ちなみに私は全くの度素人であり、マクロもネット上で検索して見つけたものをそのまま使用しております。－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Private Sub CommandButton1_Click() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A2") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send With CreateObject("ADODB.Stream") .Open .Type = 2 'adTypeText .Charset = "unicode" .Writetext Http.ResponseBody .Position = 0 .Charset = "utf-8" buf = .ReadText() .Close End With 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function Private Sub タイトル抽出_Click() End Sub －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－宜しくお願い致します。

エクセルでメタタグを抽出するには？

すいません、前回質問した者です。前回の質問では・・・エクセルシートのB列にURLが並んでいるとして、ＶＢＡを使って、C列には「description」D列には「keywords」を抽出したいという質問をしたのですが、参考になる回答がなかったのでもう一度質問します。以前、私が教えてもらったのは、B列にURLが並んでいて、Ａ列にタイトルを抽出させたものでした。それが以下になります。 Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("B1") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send buf = StrConv(Http.ResponseBody, vbUnicode) 'msgbox buf url.Offset(0, -1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function このような感じでＢ列にはURLの一覧があるとして、Ａ列にタイトル、C列にdescription　D列にkeywordsが抽出できればいいなと考えています。ちなみに、私にはＶＢＡの知識がまったくありません。とりあず、これだけ出来れば、すごく助かるのですが、どなたか教えていただけないでしょうか？　よろしくお願いします！

サイトタイトルを取得するマクロが「応答なし」になる

下記のマクロは、選択したセルのURLからサイトタイトルを取得するものです。このマクロを使って、１万を越えるURLの作業をやろうとしています。作業に取り掛かったのですが、下記のマクロがすぐに「応答なし」になり、エクセルの画面が真っ白になり、Escでマクロを止めることもできません。ようやくマクロを止めても応答なしのときはマクロが動いておらず、作業が進みません。取得するサイトタイトルの数が多いため、寝てるときにマクロを動かしてやっていきたいです。下記のマクロを「応答なし」にせずに、順調にサイトタイトルを取得していくには、どのような記述にすれば、できるようになるでしょうか？ EXCEL2016です。よろしくお願いいたします。 ↓応答なしになるマクロ Sub サイトタイトル() Dim rng As Range Dim url As String Dim s As String For Each rng In Selection url = rng.Value If url <> "" Then If url Like "*://*" Then s = GetTitle(rng.Value) Else s = GetTitle("https://" & url) If s = "Error" Then s = GetTitle("http://" & url) If s = "Error" Then s = GetTitle("https://www." & url) If s = "Error" Then s = GetTitle("http://www." & url) End If rng.Offset(, 1) = s End If Next End Sub Function GetTitle(url As String) As String Dim http As Object Dim html As Object Set http = CreateObject("MSXML2.XMLHTTP") Set html = CreateObject("htmlfile") GetTitle = "Error" On Error Resume Next http.Open "GET", url, False http.send If http.Status <> 200 Then Exit Function On Error GoTo 0 html.Write http.responseText GetTitle = html.Title End Function

エクセルファイル　行列入れ替えたもの同時作成VBA

あるxmlファイルを一旦テキストファイルにしてそこから数値をエクセルファイルに移行してひとつはM.xlsxとしそれに続いて行列を入れ替えたエクセルファイルR.xlsxを作りたいのですが M.xlsx　R.xlsxのそれぞれを作るコードを単純に　合体させただけではどうも　できません M.xlsxだけ　また　R.xlsxだけの作成するコードは　出来たのですがそれぞれ別のマクロとして実行することになりますひとつのマクロでM.xlsx　R.xlsx同時に作成するVBAコードは可能でしょうか宜しくお願い致しますちなみに該当コードを単純化して合体したのが以下のものです win10 office10 Sub 783縦() Dim FileName As Variant ChDir "\\DESKTOP-O5\f" FileName = Application.GetOpenFilename(FileFilter:="xmlファイル,*.xml") If FileName = False Then MsgBox "キャンセルされました" Exit Sub End If FileCopy FileName, Left(FileName, InStrRev(FileName, "\")) & "テキスト.txt" Const MyFile = "\\DESKTOP-O5\f\テキスト.txt" Const Key1 = "<Name>" Const Key2 = "</Name>" Const Key3 = "<NameKana>" Const Key4 = "</NameKana>" Const PutBokName = "M.xlsx" Dim buf As String Dim Len1 As Long Dim Len2 As Long Dim Pos1 As Long Dim Pos2 As Long Dim Len3 As Long Dim Len4 As Long Dim Pos3 As Long Dim Pos4 As Long Dim PutBook As Workbook With CreateObject("ADODB.Stream") .Charset = "UTF-8" .Open .LoadFromFile MyFile buf = .ReadText .Close End With Len1 = Len(Key1) Len2 = Len(Key2) Pos1 = InStr(buf, Key1) Pos2 = InStr(buf, Key2) Len3 = Len(Key3) Len4 = Len(Key4) Pos3 = InStr(buf, Key3) Pos4 = InStr(buf, Key4) Set PutBook = Workbooks.Add With PutBook.Sheets(1) .Cells(1, 1).Value = "氏名" .Cells(1, 2).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1)) .Cells(2, 1).Value = "氏名カナ" .Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3)) 'クリップボードをクリア Application.CutCopyMode = False PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName End With Const PutBokName = "R.xlsx" Dim buf As String Dim Len1 As Long Dim Len2 As Long Dim Pos1 As Long Dim Pos2 As Long Dim Len3 As Long Dim Len4 As Long Dim Pos3 As Long Dim Pos4 As Long Dim PutBook As Workbook With CreateObject("ADODB.Stream") .Charset = "UTF-8" .Open .LoadFromFile MyFile buf = .ReadText .Close End With Len1 = Len(Key1) Len2 = Len(Key2) Pos1 = InStr(buf, Key1) Pos2 = InStr(buf, Key2) Len3 = Len(Key3) Len4 = Len(Key4) Pos3 = InStr(buf, Key3) Pos4 = InStr(buf, Key4) Set PutBook = Workbooks.Add With PutBook.Sheets(1) .Cells(1, 1).Value = "氏名" .Cells(2, 1).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1)) .Cells(1, 2).Value = "氏名カナ" .Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3)) 'クリップボードをクリア Application.CutCopyMode = False PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName End With End Sub -------------------------------

VBAでソースから全てのURLを取得したい

VBAでソースに書いてある全てのURLを取得したいのですが、現状では一部しか取得できません。文字数制限にでも引っかかっているのでしょうか？どうすれば全てのURLを取得できるのか・・添削して頂けると or ヒントを教えて頂けると助かります。よろしくお願いします。 (Excel2003を使用) Sub test() Dim objIE As Object Dim objTAG As Object Dim source As String Dim url As String Dim url_start As String Dim url_end As String Dim y As Long url_end = 1 y = 1 Set objIE = CreateObject("InternetExplorer.application") objIE.Visible = False objIE.Navigate "http://dir.yahoo.co.jp/" Do While objIE.Busy = True DoEvents Loop Application.Wait Time:=Now + TimeValue("00:00:03") source = objIE.Document.All(1).Innerhtml Do While y < 10000 url_start = InStr(url_end, source, "<a href=", vbTextCompare) If url_start = 0 Then y = 10000 Else url_end = InStr(url_start, source, ">", vbTextCompare) url = Mid(source, url_start + 9, url_end - url_start - 10) Cells(y, 1).Value = url y = y + 1 End If Loop End Sub

縦に取得するのを横にする＆最後に取得したところから

下記のマクロで、A1の語句をGoogle検索して、上位５位のタイトル・URLをA2～A11へ記入できます。そのA1に語句、A2～A11に上位５位というのを、 A1に語句、B1～K1に上位５位という風に変更したいです。 A1（語句）｜A2（タイトル）｜A3（URL）｜ ↓ A1（語句）｜B1（タイトル）｜C1（URL）｜という感じです。もう一つ、途中でロボットでない証明のクリックがあります。そのため、マクロを止めざるおえないです。改めて、マクロを再開する時に、最後に取得した語句から始めるようにしたいです。これらは、どのようなマクロの記述になるでしょうか？ EXCEL２０１６です。よろしくお願いいたします。 '//標準モジュール Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) Dim objIE As SHDocVw.InternetExplorer '参照設定 Microsoft Internet Contorls Dim oHTML As HTMLDocument '参照設定 Microsoft HTML Object Library Sub Main() 　Dim c As Range 　Dim enSrTxt As String 　Dim counter As Long 　On Error GoTo ErrHandler 　Const BASEURL As String = "https://www.google.co.jp/search?q=" 　With ActiveSheet 　　Set objIE = Nothing 　　For Each c In .Range("A1", .Cells(1, Columns.Count).End(xlToLeft)) 　　　If c.Value <> "" Then 　　　　If c.Value Like "*[ぁ-龠]*" Then 　　　　　enSrTxt = EnUtf8(c.Value) 　　　　Else 　　　　　enSrTxt = c.Value 　　　　End If 　　　　Call getIE(BASEURL & enSrTxt) 　　　　'Application.Wait TimeSerial(0, 0, 10) '遅くしていた元凶　　　　Sleep 500 　　　　counter = counter + 1 　　　End If 　　Next c 　End With ErrHandler: 　If Err <> 0 Then 　　MsgBox Err.Description 　End If End Sub Sub getIE(ByVal strURL As String) 　Dim cnt As Long 　Dim cl As Object 　Dim c As Range 　Dim nm As Long 　Set oHTML = New HTMLDocument 　If objIE Is Nothing Then 　　Set objIE = New SHDocVw.InternetExplorer 　End If 　Set c = Cells(2, Columns.Count).End(xlToLeft) '二行目で計る　If c.Value <> "" Then nm = c.Column + 1 Else nm = c.Column 　With objIE 　　.Visible = True 　　.navigate strURL 　　Do While .Busy Or .readyState <> 4: DoEvents: Loop 　　Set oHTML = .document 　End With 　　Call outputLog(oHTML, nm) 　　Set cl = objIE.document.getElementsByClassName("csb ch") 　　cl(1).Click 　　DoEvents 　　Sleep 500 　　Do While objIE.Busy Or objIE.readyState <> 4: DoEvents: Loop 　　Set oHTML = objIE.document 　Cells(1, nm).EntireColumn.AutoFit 　Application.ScreenUpdating = True End Sub Sub outputLog(oHTML As HTMLDocument, nm As Long) 　Dim buf As Variant 　Dim j As Long, i As Long, k As Long 　Dim gLinks As Object 　Dim mTitle As Variant 　Dim cnt As Long 　j = Cells(Rows.Count, nm).End(xlUp).Row + 1 　With oHTML 　 Set mTitle = oHTML.getElementsByClassName("LC20lb") 　　Set gLinks = oHTML.getElementsByClassName("TbwUpd") 　　If gLinks.Length > 0 Then 　　 If (gLinks.Length - 1) > 4 Then cnt = 4 Else cnt = gLinks.Length - 1 　　　For i = 0 To cnt '' 5コまで、　　　　Cells(j, nm).Value = mTitle(i).innerText 　　　　buf = gLinks(i).ParentNode.href 　　　　If InStr(1, buf, "%") > k Then buf = DecodeUTF8(buf) 　　　　Cells(j + 1, nm).Value = buf 　　　　Cells(j + 1, nm).Font.ColorIndex = 4 'フォントの色　　　　j = j + 2 　　　　buf = "" 　　　Next 　　End If 　End With End Sub Private Function EnUtf8(ByRef strSource As String) As String 　'Encode 　Dim objSC As Object 　Set objSC = CreateObject("ScriptControl") 　objSC.Language = "Jscript" 　EnUtf8 = objSC.CodeObject.encodeURIComponent(strSource) 　Set objSC = Nothing End Function Private Function DecodeUTF8(ByVal strSearch As String) 　'Decord 　If strSearch = "" Then Exit Function 　With CreateObject("ScriptControl") 　　.Language = "JScript" 　　With .CodeObject 　　　DecodeUTF8 = .decodeURI(strSearch) 　　End With 　End With End Function

グーグルに登録されているかをチェックする場合

エクセルのE列にURLがあるとします。（数は500～1000ぐらい） F列には、Ｅ列にあるURLをグーグルで検索し、検索結果がある場合は、「○」ない場合は「×」で判定します。 G列には、グーグルで検索結果の約○○件、あるいは○件、これら○に入る数字を取得したいです。そこで、以前、同じことを教えてもらったのですが、グーグルの使用が変更になったせいかすべて検索結果が「×」判定となってしまいました。そのコードが下記なのですが、どこを修正すればいいのか教えてください。よろしくお願いします。 '標準モジュール Private Const SKEY As String = "http://www.google.co.jp/search?hl=ja&q=" Public Sub GoogleCheckers() Dim c As Range Dim buf As String Const qt As String = "" With ThisWorkbook.Sheets("登録チェック") For Each c In Range("E6", Cells(Rows.Count, 5).End(xlUp)) If c.Value <> "" Then Application.ScreenUpdating = False buf = UrlEncode(c.Value) buf = SKEY & buf ItemCehck buf, c Application.ScreenUpdating = True End If Next End With End Sub Private Sub ItemCehck(ByVal strURL As String, iRng As Range) Dim rng As Range Dim objHTTP As Object Dim i As Long, j As Long Dim c As Variant Dim httpLog As String Dim msgbuf As Variant Dim LimitNum As Long On Error GoTo ErrHandler Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1") objHTTP.Open "GET", strURL, False objHTTP.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows; U; Windows NT 5.1; en-JA; rv:1.9.2.12)" objHTTP.Send If Err.Number = 0 Then If objHTTP.Status = 200 Then httpLog = objHTTP.ResponseText Call ContentsCheck(httpLog, iRng) ElseIf objHTTP.Status >= 400 Then iRng.Offset(, 1).Value = "アクセスエラー" End If Else iRng.Offset(, 1).Value = "?" End If Exit Sub ErrHandler: iRng.Offset(, 1).Value = "不明" End Sub Private Sub ContentsCheck(httpLog As String, rng As Range) 'rev:101226 Dim i As Long, j As Long Dim buf As Variant Const STXT As String = "検索オプション</a></div><div><div id=resultStats>" i = InStr(1, httpLog, STXT, 1) If i > 0 Then buf = Mid(httpLog, i + Len(STXT), 50) j = InStr(1, buf, "件<nobr>", 1) buf = Mid(buf, 1, j) buf = Replace(buf, "約", "") buf = Replace(buf, "件", "") End If If CLng(Val(buf)) > 0 Then rng.Offset(, 1).Value = "○" rng.Offset(, 2).Value = buf Else rng.Offset(, 1).Value = "×" End If End Sub Private Function UrlEncode(ByVal sText As String) As String Dim buf As String If Len(sText) = 0 Then Exit Function With CreateObject("ScriptControl") .Language = "JScript" buf = .CodeObject.encodeURI(sText) buf = Replace(buf, ":", "%3A", , , 1) buf = Replace(buf, "/", "%2F", , , 1) UrlEncode = buf End With End Function

VBAで文字の位置が正確に取得できない

Excel2003のマクロで、URLを抜き出すマクロを作っているのですが、なぜかurl_endの値が正確に取得できません。何がいけないのでしょうか？事象 url_endに格納される値がなぜか1376(くらいだったような・・)になってしまう。 url_startには1260が格納されており、<a href=の部分をきちんと取得している。ソース Sub test() Dim objIE As Object Dim objTAG As Object Dim souce As String Dim url As String Dim url_start As String Dim url_end As String url_end = 1 Set objIE = CreateObject("InternetExplorer.application") objIE.Visible = False objIE.Navigate "http://dir.yahoo.co.jp/" Do While objIE.Busy = True DoEvents Loop Application.Wait Time:=Now + TimeValue("00:00:02") url_start = InStr(url_end, objIE.Document.All(1).Innerhtml,"<a href=", vbTextCompare) url_end = InStr(url_start,objIE.Document.All(1).Innerhtml, ">", vbTextCompare) url = Mid(objIE.Document.All(1).Innerhtml, url_start, url_end) Cells(1, 1).Value = url End Sub

このマクロの説明をお願いします

Dim buf As String Private Sub CommandButton1_Click() End Sub Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim tmp As Variant Application.EnableEvents = False tmp = InStr(2, buf, "$", vbTextCompare) tmp = Right(buf, Len(buf) - tmp) If buf = "$B$" & tmp Then Range("C" & tmp).Value = Range("C" & tmp).Value + Range("B" & tmp).Value Range(buf).Select End If Application.EnableEvents = True End Sub Private Sub Worksheet_SelectionChange(ByVal Target As　Excel.Range) buf = ActiveCell.Address End Sub どうやらB列の各セルに入力がされた場合、隣接するC列のセルに加算していくマクロのようです。なんですが、 InStr関数、Right関数、Len関数あたりでやっていることがよくわかりません。 Private Sub CommandButton1_Click()は必要なのでしょうか？あと、もっとシンプルなマクロができるようでしたらご教授ねがいます。

現在開いている全てのIEのURLのタイトルを取得し

現在開いている全てのIEのURLのタイトルを取得したいのですが Sub test() Dim shl As Object Dim wnd As Object Dim doc As Object Dim frg As Boolean Set shl = CreateObject("Shell.Application") For Each wnd In shl.Windows() If TypeName(wnd.Document) = "HTMLDocument" Then Set doc = wnd.Document Debug.Print doc.Title Set doc = Nothing End If Next Set shl = Nothing End Sub このコードが If TypeName(wnd.Document) = "HTMLDocument" Then でエラーになる時とならない時があります。エラーになる時は、実行時エラー　-2147467259 ’Document’メソッドは失敗しました：'IWebBrowser２'オブジェクトとなります。エラーが発生する時としない時の違いが分かりません。そもそもどういう意味のエラーでしょうか？ IE11、オフィス２０１０です。

EXCELで作ったマクロを別のファイルのEXCELでも使えるようにしたいです。

(1)EXCELファイルでマクロを作成しました。 (実際はここである人の知恵をお借りして作ったものですが…) しかし、(2)EXCELファイルで(1)EXCEL作成マクロが実行できません。どのような処理をすれば、どのPCでも、どのファイルでも実行できるようなマクロに出来るのでしょうか？？以下にそのマクロを示します。 ↓↓↓ Sub 文字置換() '半角カタカナを全角に、全角英数を半角にするマクロ　(Excel編） Dim rng As Range Dim Re As Object Dim myPat As String Dim c As Range Dim Matches As Object Dim Match As Object Dim Str1 As String Dim Str2 As String Dim buf As String Dim t As Long On Error Resume Next Set rng = ActiveSheet.UsedRange.SpecialCells _ (xlCellTypeConstants, xlTextValues) On Error GoTo 0 If rng Is Nothing Then MsgBox "変換する対象が見当たりません。", 48 Exit Sub End If '全角側　---　半角側 (！-／を加えれば記号も半角) myPat = "([\uFF66-\uFF9F]*)([！-｝]*)" '正規表現のパターン Set Re = CreateObject("VBScript.RegExp") Application.ScreenUpdating = False With Re .Global = True .IgnoreCase = True .Pattern = myPat For Each c In rng.Cells Set Matches = .Execute(c.Value) If Matches.Count > 0 Then buf = c.Value For Each Match In Matches If Len(Match.Value) > 0 Then Str1 = StrConv(Match.SubMatches(0), vbWide) If Str1 <> "" Then '0 =vbBinaryCompare buf = Replace(buf, Match.SubMatches(0), Str1, , , 0) End If Str2 = StrConv(Match.SubMatches(1), vbNarrow) If Str2 <> "" Then buf = Replace(buf, Match.SubMatches(1), Str2, , , 0) End If End If Str1 = "": Str2 = "" Next Match If buf <> c.Value Then c.Value = buf t = t + 1 End If End If Next c End With Set Re = Nothing Application.ScreenUpdating = True If t > 0 Then MsgBox t & "個のセルを変換しました。", 64 End If End Sub 出来れば、置換した文字数をメッセージBOXに表示したいです。

Excel2010 VBA 条件色付け

Sub sample() Dim r As Range For Each r In Range("q6:q30") If myIsNumeric(r) Then r.Offset(0, 1).Value = "数字" Else r.Offset(0, 1).Value = "文字" End If Next End Sub Function myIsNumeric(Target As Range) Dim r As Range Dim buf, tmp Dim flg As Boolean Dim i As Integer buf = Target For i = 1 To Len(buf) tmp = Mid(buf, i, 1) If IsNumeric(tmp) Then flg = True Exit For End If Next myIsNumeric = flg End Function を数字が入ってたら塗りつぶさないで、数字が入ってなかったら塗りつぶすように直したいです。あああ→塗るあああ1－1→塗らない住所→塗る住所12→塗らない

エクセルマクロ　検索して値を取得

マクロはよく分かっていません。既存のVBAを見ながらマネしてる状態なので、どこが間違っているのか教えて下さい。 sheet1 A 所属 1 789　　　　　　　　 2　　　　 3 sheet2 　　 A 　　　　B 所属コード　　所属 1　12345　　　あいう123 2　12346　　　あいう456　　 3 12347　　　あいう789 やりたいことシート１の所属が「789」だったらとシート２の所属から「あいう789」を検索し、シート２の所属コード「12347」をシート１の所属に返す。私が作ったやつだと「12347」は１行目でなく、３行目に返ってしまいます。 Dim SyozokuRange as Range Dim Syozoku as String Dim Buf as String Buf = "あいう" Syozoku = Buf & Syozoku Set SyozokuRange = worksheets(2).range("a:b").currentregion For i = 1 to SyozokuRange.rows.count If Syozoku = SyozokuRange.cells(i,2) Then worksheets(1).cells(i,1).value = SyozokuRange.cells(i,1) end if next i

【VBA】セルの中身を日付形式に変換したい

w列のセルの中に20140701のように入っているセルを2014/07/01に変換するマクロを作っております。それで以下のように書いてみたのですが、「型が一致しません」と出てしまい、先に進めずにおります…。お力借りられますと幸いです。 Dim org As String Dim buf As String Dim i As Long i = 1 Do Until Cells("w", i) = "" Cells("w", i).Select With ActiveCell org = .Value If Len(org) = 8 Then buf = _ Mid(org, 1, 4) & "/" & _ Mid(org, 5, 2) & "/" & _ Mid(org, 7, 2) If IsDate(buf) = True Then .Value = buf .NumberFormatLocal = "yyyy年m月d日" End If End If End With i = i + 1 Loop

CheckBoxとTextBoxの値を貼付る方法

よろしくお願いします。 Dim n As Long Dim r As Range Dim C, buf As String n = Cells(Rows.Count, "A").End(xlUp).Row + 1 Range("A" & n).Select For Each C In Controls If TypeName(C) = "CheckBox" Then If C.Value Then buf = buf & C.Caption & vbCrLf End If Next C ActiveCell.Offset(-1, 16).Value = buf & TextBox9.Value ’buf＝チェックされている複数のCheckBoxのCaption ’この時のActiveCell.Offset(-1, 16).ValueにはbufとTextBox9の値も表示されています。 End If で、セルに入力して ActiveCell.Offset(0, 7).Value = ActiveCell.Offset(-1, 16).Value で、セルに貼り付けようとすると、bufの値のみ表示されてTextBox9の値が表示されません。 bufの値とTextBox9の値と両方をコピー表示する方法をお教えください。

下記のマクロをもっと早くするには？

下記のマクロは、 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

AccessVBAで、ホームページの内容を取得すると文字化けする

とあるサイトで下記のようなVBAソースを拾って、実行してみたところ、日本語部分が文字化けしてしまいました。 --- ここから Dim Http Dim Buf As String 'GET Set Http = CreateObject("MSXML2.XMLHTTP") Http.Open "GET", "http://www.yahoo.co.jp", False Http.send Buf = StrConv(Http.ResponseBody, vbUnicode) --- ここまでこれでBufにサイトのHTMLが格納されますが、日本語部分が文字化けしてしまいます。どうにかして回避できないものでしょうか。

Shell32ライブラリのインスタンスのオブジェクト

エクセルからインターネットエクスプローラを操作して、任意のULRをからデータを取得しようと考えています。URLのアドレスとテキスト名を引数として、IEへのオブジェクトを返す関数を作ろうかと思いましたが、一向にうまくいきません。コードの99%は、ネット、雑誌からの引用なので問題はない(継ぎ接ぎ上の問題はあるかと思いますが)と思います。やりたいことは、関数から返されるオブジェクトを使ってのTest()の最後の2行の.body.innerTextと、.body.innerHTMLの取得です。どなたか詳しい方がいらっしゃいましたら教えてください。よろしくお願いいたします。 Sub test() Dim myIE As Object Dim URL_address As String Dim URL_Title As String Dim IE_Text As String Dim IE_Html As String ULR_address = "http://oshiete1.goo.ne.jp/c232.html" Ulr_Title = "教えて！goo Office系ソフト" myIE = IE_URL(URL_address, Ulr_Title) IE_Text = myIE.document.body.innerText IE_Html = myIE.document.body.innerHTML End Sub Function IE_URL(URL_address As String, URL_Title As String) As Object Dim myIE As SHDocVw.InternetExplorer Dim myIE2 As Object '　起動しているIEの中にURL_Titleと合致するULRがあるか調べる With New Shell32.Shell For Each myIE In .Windows If UCase(Dir(myIE.FullName)) = "IEXPLORE.EXE" Then If myIE.document.Title = URL_Title Then myIE.Navigate URL_address Exit For End If End If Next End With 'URL_Titleと合致するURLがない場合、新たにIEを立ち上げて表示させる If myIE Is Nothing Then With New SHDocVw.InternetExplorer ' .Navigate URL_address .Visible = True End With Application.Wait Now + TimeValue("00:00:01") 'myIEにオブジェクトをセットさせるために再度全体を検索する(上のwithでオブジェクトを取得できれば不要) With New Shell32.Shell For Each myIE In .Windows If UCase(Dir(myIE.FullName)) = "IEXPLORE.EXE" Then If myIE.document.Title = URL_Title Then myIE.Navigate URL_address Exit For End If End If Next End With End If Set myIE2 = GetObject(myIE.FullName) IE_URL = myIE2 End Function

WindowsのプロダクトIDを取得する方法について

WindowsのプロダクトIDを取得する方法について Active Basic 4.24.00を使用してプログラムを書いています。（AB5はバグがあるためまだ使用していません。） http://www.ruriplus.com/msaccess/tch/tch_036.html 上記のサイト様を参考に、WindowsのProduct IDを取得しようとしています。（参考というより、コピペなのですが・・・）しかし、きちんと取得してくれません。 AB用に以下のように書き直しました。 Function GetWinProductId() As String Dim stSubKey As String Dim stProductid As String Dim hkeyRoot As HKEY Dim lErr As Long Dim OSVER As OSVERSIONINFO Dim dummy As Long stProductid=ZeroString(256) OSVER.dwOSVersionInfoSize = Len(OSVER) lErr = GetVersionEx(OSVER) If lErr = 0 Then Exit Function If OSVER.dwPlatformId = VER_PLATFORM_WIN32_NT Then stSubKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion" Else stSubKey = "SOFTWARE\Microsoft\Windows\CurrentVersion" End If lErr = RegOpenKeyEx(HKEY_LOCAL_MACHINE, stSubKey, &0, KEY_READ, hkeyRoot) If lErr <> 0 Then MessageBox(0,"ERROR","1",0) Exit Function End If lErr = RegQueryValueEx(hkeyRoot, "ProductId", &0, REG_SZ,stProductid, 256) If lErr <> 0 Then MessageBox(0,"ERROR","2",0) Exit Function End If lErr = RegCloseKey(hkeyRoot) If lErr <> 0 Then MessageBox(0,"ERROR","3",0) Exit Function End If GetWinProductId = Left$(stProductid, 255 /*InStr(1, stProductid, vbNullChar, vbBinaryCompare)*/) End Function MessageBox(0,GetWinProductId(),0,0) ※ Left$(stProductid, 255 /*InStr(1, stProductid, vbNullChar, vbBinaryCompare)*/) この部分は、よく分からなかったので、とりあえず放置しています。その前に、変数『stProductid』に値が帰ってこないのです。（RegQueryValueExでエラーが返る。FormatMessageでエラーを見ると、正常終了している。・・・が、0以外の値が返ってくる）すいませんが、ご存知の方、やり方をご教示ください。お願いします。

URLからタイトルを取得したい！

みんなの回答

補足 2011/04/11 17:13

関連するQ&A

エクセルでURLからタイトルのみを抽出する方法

エクセルでマクロの進行状況を表示あるには

エクセルでメタタグを抽出するには？

サイトタイトルを取得するマクロが「応答なし」になる

エクセルファイル　行列入れ替えたもの同時作成VBA

VBAでソースから全てのURLを取得したい

縦に取得するのを横にする＆最後に取得したところから

グーグルに登録されているかをチェックする場合

VBAで文字の位置が正確に取得できない

このマクロの説明をお願いします

現在開いている全てのIEのURLのタイトルを取得し

EXCELで作ったマクロを別のファイルのEXCELでも使えるようにしたいです。

Excel2010 VBA 条件色付け

エクセルマクロ　検索して値を取得

【VBA】セルの中身を日付形式に変換したい

CheckBoxとTextBoxの値を貼付る方法

下記のマクロをもっと早くするには？

AccessVBAで、ホームページの内容を取得すると文字化けする

Shell32ライブラリのインスタンスのオブジェクト

WindowsのプロダクトIDを取得する方法について

注目のQ&A

カテゴリ

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

専門家に質問してみよう

URLからタイトルを取得したい！

みんなの回答

補足 2011/04/11 17:13

関連するQ&A

エクセルでURLからタイトルのみを抽出する方法

エクセルでマクロの進行状況を表示あるには

エクセルでメタタグを抽出するには？

サイトタイトルを取得するマクロが「応答なし」になる

エクセルファイル 行列入れ替えたもの同時作成VBA

VBAでソースから全てのURLを取得したい

縦に取得するのを横にする＆最後に取得したところから

グーグルに登録されているかをチェックする場合

VBAで文字の位置が正確に取得できない

このマクロの説明をお願いします

現在開いている全てのIEのURLのタイトルを取得し

EXCELで作ったマクロを別のファイルのEXCELでも使えるようにしたいです。

Excel2010 VBA 条件色付け

エクセルマクロ 検索して値を取得

【VBA】セルの中身を日付形式に変換したい

CheckBoxとTextBoxの値を貼付る方法

下記のマクロをもっと早くするには？

AccessVBAで、ホームページの内容を取得すると文字化けする

Shell32ライブラリのインスタンスのオブジェクト

WindowsのプロダクトIDを取得する方法について

注目のQ&A

カテゴリ

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

専門家に質問してみよう

エクセルファイル　行列入れ替えたもの同時作成VBA

エクセルマクロ　検索して値を取得