読者です 読者をやめる 読者になる 読者になる

DuKiccoの雑記

My Life Is Myself

【Yahoo検索結果をエクセルにテーブル形式で抽出する】【エクセル2013,VBA】

VBA エクセル

Yahoo検索結果をWebクエリを利用してエクセルにテーブル形式で抽出する。

手順
1.Yahoo検索結果をWebクエリによりシート1へ表示
↓Yahoo検索結果(エクセル vba)のWebクエリ
f:id:DuKicco:20161120230522j:plain

2.シート1の内容(いつもの検索結果の並び)をシート2へテーブル形式で並べ直す。
↓並び替え後
f:id:DuKicco:20161120230509j:plain


support.office.com


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

エクセル VBA



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

エクセル VBA


PubmedAPIを利用して文献IDからAbstractやTitleを読み込むFunction

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】

VBA エクセル

robocopywindows 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

イミディエイト ウィンドウに表示された結果。コピー・上書きファイル数などが表示される。
f:id:DuKicco:20160612014851j:plain

【画像処理、ImageMagickをエクセルVBAから使う】

エクセル VBA

目的
様々な画像処理をVBAから行う。
画像処理例
・フォルダ内の画像ファイルを一括で縮小やリサイズを行う
・フォルダ内の画像ファイルを一括で別形式に変換する(→jpg,png,pdf,etc)
・フォルダ内のjpgファイルをまとめ1つのpdfファイルにする
・画像ファイルのサイズ等の情報を取得する
・2つの画像を合成する


上記の内容はVBA単独では難しいのでフリーソフトImageMagickVBAから利用できるようにする。
ImageMagickとは?

www.atmarkit.co.jp


準備
1.ImageMagickのダウンロード
Windowsのbit数ではなく使用するOfficeのbit数に合わせるとのこと
http://www.imagemagick.org/script/binary-releases.php
f:id:DuKicco:20160607070453j:plain

2.ImageMagickのインストール
VBAから利用できるように「Install ImageMagickObject OLE Control for VBScript, Visual Basic, and WSH」にチェックを入れる
f:id:DuKicco:20160607070407j:plain


3.VBAでのImageMagicObjectの参照設定にチェクを入れる
f:id:DuKicco:20160607070432j:plain


以下、実例

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】

エクセル 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="


f:id:DuKicco:20160606074254j:plain


ちなみに証券コード(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種類のフォントがダウンロードできます。

www.technical.jp

選択したフォントによっては前後に特定の文字を付ける必要があります。

 

参考

フォントのインストール方法(Windows 7 の場合)

 *アドミン権限が必要でした。

 

www.keyence.co.jp