【Yahoo検索結果をエクセルにテーブル形式で抽出する】【エクセル2013,VBA】
Yahoo検索結果をWebクエリを利用してエクセルにテーブル形式で抽出する。
手順
1.Yahoo検索結果をWebクエリによりシート1へ表示
↓Yahoo検索結果(エクセル vba)のWebクエリ
2.シート1の内容（いつもの検索結果の並び）をシート2へテーブル形式で並べ直す。
↓並び替え後
Sub Yahoo検索結果取得V1() Application.ScreenUpdating = False Application.DisplayAlerts = False Dim i As Long, j As Long, k As Long, arr As Variant, flag As Boolean, HLA As String, Title As String, spage As Long Dim URLstr As String, SN1 As String '検索ワード sWord = InputBox("検索ワードを入力", "入力", "excel vba") arr = Split(sWord) '検索ワードをエンコード sWord = UrlEncode(arr(0)) For i = 1 To UBound(arr) sWord = sWord & "+" & UrlEncode(arr(i)) Next 'MsgBox sWord k = 2 '並び替え先シートを作成 Call SheetAdd("Result") SN1 = ActiveSheet.Name With ActiveSheet .Cells(1, 1) = "No" .Cells(1, 1).ColumnWidth = 5 .Cells(1, 2) = "Title" .Cells(1, 2).ColumnWidth = 20 .Cells(1, 3) = "URL" .Cells(1, 3).ColumnWidth = 20 .Cells(1, 4) = "本文" .Cells(1, 4).ColumnWidth = 20 End With 'Webクエリの出力先シートを作成 Call SheetAdd("Temporary") SN2 = ActiveSheet.Name '表示を開始する件数 spage = 1 'Yahoo検索URL URLstr = "https://search.yahoo.co.jp/search?p=" & sWord & "&aq=-1&ei=UTF-8&fr=top_ga1_sa&b=" & spage 'Webクエリの出力 With ActiveSheet.QueryTables.Add( _ Connection:="URL;" & URLstr, _ Destination:=Range("A1")) .Name = "Result" .WebSelectionType = xlEntirePage .WebFormatting = xlWebFormattingAll .BackgroundQuery = False .Refresh End With 'MsgBox URLstr flag = False 'HyperLinkAddress HLA = "" 'Hyperlinks.TextToDisplay Title = "" '"Webクエリ"シートを2行目から読み込み For i = 2 To ActiveSheet.UsedRange.Rows.Count '次へで終了位置と認識 If InStr(Sheets(SN2).Cells(i, 1), "次へ>") > 0 Then Exit For End If If Cells(i, 1).Hyperlinks.Count > 0 Then On Error Resume Next 'HyperLinkAddressに「yahoo.yahoofs,javascript」など含まれるものは対象外と判断 If InStr(Sheets(SN2).Cells(i, 1).Hyperlinks(1).Address, "yahoo.co.jp") > 0 Or InStr(Sheets(SN2).Cells(i, 1).Hyperlinks(1).Address, "cache.yahoofs.jp") > 0 Or InStr(Sheets(SN2).Cells(i, 1).Hyperlinks(1).Address, "javascript") > 0 Then Else Title = Sheets(SN2).Cells(i, 1).Hyperlinks(1).TextToDisplay HLA = Sheets(SN2).Cells(i, 1).Hyperlinks(1).Address '開始位置の判断 If Title = "" Or HLA = "" Then flag = False Else flag = True End If End If On Error GoTo 0 Else tst = Sheets(SN2).Cells(i, 1) 'Debug.Print tst If flag = True Then If Sheets(SN1).Cells(k - 1, 2).Value <> Title Then Sheets(SN1).Cells(k, 1) = k - 1 Sheets(SN1).Hyperlinks.Add anchor:=Sheets(SN1).Cells(k, 2), _ Address:=HLA, _ TextToDisplay:=Title Sheets(SN1).Cells(k, 3) = HLA Sheets(SN1).Cells(k, 4) = tst k = k + 1 End If End If 'Debug.Print i & HLA & "_" & Title & "_"; tst End If Next i Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "完了" End Sub ' URL Encode(64bit) Function UrlEncode(ByVal TString As String) As String Dim TempObj As Object Dim TempEl As Object TString = Replace(TString, "\", "\\") TString = Replace(TString, "'", "\'") Set TempObj = CreateObject("htmlfile") Set TempEl = TempObj.createElement("span") TempEl.setAttribute "id", "result" TempObj.appendChild TempEl TempObj.parentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & TString & "');", "JScript" UrlEncode = TempEl.innerText End Function Sub SheetAdd(SNHead As String) '指定された文字ではじまるのシート名がかぶらぬよう連番で加える Dim mySheet As Worksheet Dim i As Long, tst As String, flag As Boolean 'Max100Sheet For i = 1 To 100 flag = True tst = SNHead & i For Each mySheet In Worksheets If mySheet.Name = tst Then '名前がかぶったらfalse flag = False End If Next If flag Then Worksheets.Add ActiveSheet.Name = tst Exit Sub End If Next End Sub
エクセル,vba,xml,Pubmed,API,PMID
PubmedAPIを利用してPubmed検索結果のPMIDをセルに書き出す。
Pumed API
PubMed検索方法：Web Apiの勉強中: IT関係。二階堂のブログ。
XML
http://minor.hatenablog.com/entry/2015/09/02/233330
Sub GetPubMedID() 'Microsoft XML. v6.0を参照設定のこと Dim xmlNode As String Dim xdoc As MSXML2.DOMDocument Dim httpObj As Object Dim childNode As IXMLDOMNode Dim PNode As IXMLDOMNode '検索ワードを設定 検索ワード = "Cancer" url = "https://eutils.ncbi.nlm.nih.gov/entrez/eutils/esearch.fcgi?db=pubmed&term=" & 検索ワード & "&retmode=xml" xmlNode = "//eSearchResult/IdList" Set httpObj = CreateObject("Microsoft.XMLHTTP") httpObj.Open "GET", url, False httpObj.send ("") Set xdoc = httpObj.responseXML 'MsgBox xdoc.XML Set PNode = xdoc.SelectSingleNode(xmlNode) i = 1 For Each childNode In PNode.ChildNodes If childNode.nodeName = "Id" Then 'セルに結果を入力 Cells(i, 1) = childNode.Text i = i + 1 End If Next childNode Set httpObj = Nothing Set PNode = Nothing End Sub
エクセル,VBA,xml,Pubmed,API,abstract,Title
Sub Pubmed2() 'Functionの使い方 Dim arr As Variant, PubmedID As Long '情報を取り出したいPubmedID PubmedID = 2644239 arr = GetTitle(PubmedID) MsgBox " Abstract " & arr(1) MsgBox " Title " & arr(2) End Sub Function GetTitle(PMID As Long) As String() 'Microsoft XML. v6.0を参照設定 On Error GoTo Err Dim xmlNode(2) As String ReDim tempgettitle(2) As String Dim xdoc As MSXML2.DOMDocument Dim httpObj As Object url = "https://eutils.ncbi.nlm.nih.gov/entrez/eutils/efetch.fcgi?db=pubmed&id=" & PMID & "&retmode=xml" xmlNode(1) = "//PubmedArticleSet/PubmedArticle/MedlineCitation/Article/Abstract/AbstractText" xmlNode(2) = "//PubmedArticleSet/PubmedArticle/MedlineCitation/Article/ArticleTitle" Set httpObj = CreateObject("Microsoft.XMLHTTP") httpObj.Open "GET", url, False httpObj.send ("") Set xdoc = httpObj.responseXML 'MsgBox xdoc.XML For i = 1 To 2 Set xmltxt = xdoc.SelectSingleNode(xmlNode(i)) tempgettitle(i) = xmltxt.Text Next GetTitle = tempgettitle Set httpObj = Nothing Exit Function Err: Debug.Print "Error" End Function
【robocopyコマンドでフォルダーをバックアップ／同期する】【エクセル2013,VBA】
robocopyはwindows vista以降に装備されているコマンドで通常はコマンドプロンプトから使いますが、VBAから使ってみます。robocopyは「Robust File Copy」の略で、堅牢（robust）かつ確実なファイルのコピーという意味になります。
ファイルやフォルダのコピーにはいろいろな方法がありますが、robocopyは堅牢(?)で、オプションも豊富、コピーにかかる時間自体も短くて済むのでおすすめです。
robocopy
https://technet.microsoft.com/ja-jp/library/cc733145(v=ws.10).aspx
https://technet.microsoft.com/ja-jp/magazine/ee851678.aspx
/mirオプションの説明
コピー元のフォルダーとコピー先の内容が同一となる。差分バックアップ。
1.作成日時やファイルサイズの異なるファイルは上書きされる。
2.コピー先に存在しないファイルやフォルダは新たに作成される。
3.コピー元に存在しないファイルはコピー先から削除される。
コピー先から削除したくない場合はオプションを/s（サブフォルダーのコピー）とする。
コピー元とコピー先を間違うと消えてしまうので、事前に十分練習してください。
Sub RunRoboCopy1() Dim WSH, wExec, sCmd As String, Result As String Dim FF As String, TF As String FF = "C:\temp\コピー元" 'コピー元フォルダのパス TF = "C:\temp\コピー先" 'コピー先フォルダのパス Set WSH = CreateObject("WScript.Shell") sCmd = "robocopy " & FF & " " & TF & " /mir" '/mir→ミラオプションでバックアップ Set wExec = WSH.Exec("%ComSpec% /c " & sCmd) 'コマンドの実行 Do While wExec.Status = 0 'コマンドが終了したか確認 DoEvents Loop Result = wExec.StdOut.ReadAll '結果の取得 Debug.Print Result '結果の表示 Set wExec = Nothing Set WSH = Nothing End Sub
イミディエイト ウィンドウに表示された結果。コピー・上書きファイル数などが表示される。
【画像処理、ImageMagickをエクセルVBAから使う】
目的
様々な画像処理をVBAから行う。
画像処理例
・フォルダ内の画像ファイルを一括で縮小やリサイズを行う
・フォルダ内の画像ファイルを一括で別形式に変換する（→jpg,png,pdf,etc)
・フォルダ内のjpgファイルをまとめ1つのpdfファイルにする
・画像ファイルのサイズ等の情報を取得する
・2つの画像を合成する
上記の内容はVBA単独では難しいのでフリーソフトのImageMagickをVBAから利用できるようにする。
ImageMagickとは？
準備
1.ImageMagickのダウンロード
Windowsのbit数ではなく使用するOfficeのbit数に合わせるとのこと
http://www.imagemagick.org/script/binary-releases.php
2.ImageMagickのインストール
VBAから利用できるように「Install ImageMagickObject OLE Control for VBScript, Visual Basic, and WSH」にチェックを入れる
3.VBAでのImageMagicObjectの参照設定にチェクを入れる
以下、実例
Sub ImageMagick一括圧縮() '指定したフォルダ内の画像(jpg)を一括し圧縮する（上書き） Dim FolPath As String '任意のフォルダを選択 With Application.FileDialog(msoFileDialogFolderPicker) .Title = titlestr If .Show = -1 Then FolPath = .SelectedItems(1) Else Exit Sub End If End With Set img = New ImageMagickObject.MagickImage Debug.Print img.Identify("-format", "%h", FolPath & "\*.jpg") '選択前のサイズを出力 img.Mogrify "-resize", "65%", FolPath & "\*.jpg" '選択したフォルダ内のjpgを65%圧縮。上書きモード注意！ Debug.Print img.Identify("-format", "%h", FolPath & "\*.jpg") '選択後のサイズを出力 Set img = Nothing End Sub
【Web上のファイルや画像をダウンロード、URLDownloadToFile】【VBA】
Web上のファイルをダウンロードする際に
・ファイルのURLに法則性があり機械的に決まっている。
・ダウンロードしたファイル名を自分で決めて保存したい。
といったケースに大変便利です。
例えばYahooFinanceのトヨタ自動車（証券コード7203)の日足チャートは以下のようにURLが決まっています。
以下の日足チャートをダウンロードしてみます。
"http://chart.yahoo.co.jp/?code=7203.T&tm=1y&type=c&log=off&size=m&over=m65,m130,s&add=vm,ss&comp="
ちなみに証券コード(7203)部分を書き換えると他社の日足チャートになります。
'宣言部に以下の記述が必要 Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _ "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _ szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long Sub testURLD() '指定した証券コードの日足チャートを本ファイルと同じフォルダに証券コード名で保存する。 Dim SaveFN As String, DFURL As String, ReturnValue As Long, SCode As Long SCode = 7203 '証券コード。7203→トヨタ自動車 SaveFN = ThisWorkbook.Path & "\" & SCode & ".jpg" '画像ファイルの保存先とファイル名を設定 DFURL = "http://chart.yahoo.co.jp/?code=" & SCode & ".T&tm=1y&type=c&log=off&size=m&over=m65,m130,s&add=vm,ss&comp=" 'ダウンロードしたいファイルのURLを設定 ReturnValue = URLDownloadToFile(0, DFURL, SaveFN, 0, 0) '実行部分 If ReturnValue = 0 Then 'ダウンロードに成功すると「ReturnValue =0」となる。ただの確認 Debug.Print "ダウンロード成功" Else Debug.Print "ダウンロード失敗" End If End Sub
エクセルでバーコードを利用する-1
備品の管理をエクセルで行っているような場合に、エクセルで管理番号をバーコード印刷できると便利です。
方法は大まかに2つあります。「1は簡便、2はバーコードの種類が多く細かな設定が可能」という利点があげられます。今回は1について書きます。
1.バーコードフォントを利用する。
2.Barcodecontrolを利用する。
バーコードフォントの利用手順
フォントをダウンロード
↓
フォントのインストール
という手順になります。インストールすると明朝体などの並びにバーコードのフォントが選べるようになり、セルのフォントをバーコードフォントに指定するだけで、セルの文字がバーコードで表示されます。
以下のサイトで3種類のフォントがダウンロードできます。
選択したフォントによっては前後に特定の文字を付ける必要があります。
参考
＊アドミン権限が必要でした。
