VBAでこんなことできます_その３ 指定した銘柄の時系列株価データを取得するマクロ

どうもinageです。
VBAでどんなことできるかちょちょっと見せる用サンプル第３弾です。

「インターネット上のデータを自動で取得できるんです！」
と言って見せると
「え、そんなことできるんだ」と驚いてくれる場合と
「まあ、そりゃできるでしょ」顔をされる場合があります。

まあ、なんでもそうなんですけどね・・・。

web情報取得マクロ

どんなマクロ

4桁の証券コードを指定してボタンを押すと、時系列の株価データを表形式で取得します。

使い方

１）証券コード（4桁の数字）を入力する
２）株価取得ボタンを押す

以下、同じようにどっかから表形式のデータを持ってきたい場合の
参考までに、流れを書きたいと思います。

ただ動かしたい場合は「ファイルのダウンロード」まで飛んでください。

VBAでのIE制御について

こちらのサイトが超詳しく、勉強になりますので是非ともご覧ください。
www.vba-ie.net

ネット上のデータを取得するマクロができるまで

• データを取得したいページをなんとなく探す
• パラメータが必要か調べる
• Webページの構造を調べる
• VBAのコードを書いてみる

みたいな流れになります。

データを取得したいページ

Yahoo! ファイナンスの銘柄別時系列ページ

今回はこの、Yahoo! ファイナンスの時系列株価情報ページの表を
そのままExcelに持ってくることを考えるとします。

パラメータ？

アドレスバーを見ると「https://stocks.finance.yahoo.co.jp/stocks/history/?code=6460.T」となっています。

ここで「?code=6460.T」というのがパラメータの部分で、

「code」というパラメータに値「6460.T」を設定してね

ということです。

試しに他の銘柄を指定すると、「6460.T」の部分が変わることがわかります。

「.T」の部分はつけなくても良いみたいなので

https://stocks.finance.yahoo.co.jp/stocks/history/?code=銘柄コード

という形でアドレスを指定すれば良さそう、ということがわかります。

パラメータをつけたアドレス生成のコード（抜粋）

Dim codeStr As String
codeStr = Range("B2")
objIE.navigate "https://stocks.finance.yahoo.co.jp/stocks/history/?code=" & codeStr

この部分ですね。（B2セルに4桁のコードが入力される前提）

Webページの構造を調べる

ブラウザでホームページを見ている時に、おもむろにF12キーを押すと、
「開発者ツール」というものが開きます。
（ブラウザによって名前とか見た目は違います）

それをいい感じで使うと、ターゲットとなる表が
どのように構成されているかわかります。（説明放棄）

開発者ツールでWebページの構造を調べているところ

この場合、チェックするのは

・対象となる部分が<table>タグで出来ている
・見出しの行は<th>タグで、7つ（7列分）ある
・データ部分は<td>タグで、1行につき7つ（7列分）ある

というところです。

その情報を元に、どんなタグのデータを取得して、どこで折り返すか
を指定している部分が以下です。

    Const NumOfColumns As Long = 7    '一行の列数
    Const StartCol As Long = 5
    Const StartRow As Long = 4
    
    '対象テーブルの指定
    Set objTable = objIE.document.getElementsByTagName("table")(1)
    Set objTHs = objTable.getElementsByTagName("th")
    crRow = StartRow
    crCol = StartCol - 1
    
    '項目行の転記
    For Each obj In objTHs
        crCol = crCol + 1
        Cells(crRow, crCol) = obj.outerText
    Next
    
    Set objTDs = objTable.getElementsByTagName("td")
    cnt = 0
    crRow = StartRow + 1
    crCol = StartCol - 1
    
    'データ部分の転記
    For Each obj In objTDs
        cnt = cnt + 1
        crCol = crCol + 1
        Cells(crRow, crCol) = obj.outerText
        '既定の列数に達したら次の行に移る
        If cnt Mod NumOfColumns = 0 Then
            crCol = StartCol - 1
            crRow = crRow + 1
        End If
    Next

テーブルの指定

「objIE.document.getElementsByTagName("table")」は
tableタグのオブジェクトを配列として取得します。

今回はそれに(1)をつけることで、ソースコードに現れるtableのうち、
2番目のものを指定しています。1番目なら("table").(0) ですね。

なんで("table")(1)なの

画像のピンク枠が、1個目のテーブルです。

対象となるテーブルが何個目なのかは、まあ、htmlのソースを検索すれば
ある程度わかります。

仮に間違っても世界が終わるわけではないので、落ち着いて数字を変えながら
テストしていきましょう。

ファイルのダウンロード

web情報取得01.xlsm - Google ドライブ

上記リンク先からダウンロードしてください。

できなかったらゴメンナサイ。

諸注意

・Windowsで動作します
・デモ用なので、エラー処理とかちゃんとやってません
・自由に使っていただいて構いませんが、自己責任でお願いします
・日光に当てたり、水を与えたり、深夜12時以降に食べ物をあげたりしないでください

VBAでこんなことできます_その２ 読み込んだcsvファイルのデータをフィルタかけて別ファイルに出力マクロ

イントロ

どうもinageです。
VBAでどんなことできるかちょちょっと見せる用サンプル第２弾です。

タイトル長い。

どんなマクロ

csvファイルを選択して、読み込んで、任意の列に任意のキーワードでフィルタかけて、別ファイルに出力します。

読み込むcsvとしては
テストデータ・ジェネレータさん
で生成された住所データなどが適当かと思いますが、

基本的に1行目に項目名が入っている普通の表形式のcsvなら
大体対応できる・・・はずなのではないか感がなきにしもあらず
という気がします。

操作シート

検索列を指定して検索語を入れたときに該当件数を出すために、
数式が色々入ってます。
その辺りの内容は前回記事を参照ください。
vba-belle-equipe.hatenablog.com

使い方

１）ファイル選択ボタン-> csvファイルを選択する
２）ファイル読込ボタンを押す
３）「検索列」を選択
４）「検索語」を入力
５）シート作成ボタンを押す
６）xlsx出力かcsv出力のボタンを押す

検索列の指定～シート作成されるまで

※ちらっと写る住所や名前などは、実在しないデータです。

コード抜粋（フィルタかけて新しいシートに出すところ）

    Dim csvWS As Worksheet
    Dim newWS As Worksheet    
    Set ws = ThisWorkbook.Sheets("操作")
    Set csvWS = ThisWorkbook.Sheets("csv")

   'シートを新しく作り、検索語をその名前にする
    sheetName = ws.Range("D8") 
    Set newWS = Worksheets.Add(After:=Sheets(2))
    newWS.Name = sheetName

    Dim i As Long, j As Long
    Dim maxRow As Long
    Dim crRow As Long      '新しいシートのカレント行
    Dim buf As String
    Dim targetCol As Long
    targetCol = ws.Range(対象列アドレス)
    
    With csvWS
        '列名が入った1行目をコピーする
        .Rows(1).Copy newWS.Rows(1)
        '最終行の取得
        maxRow = .Cells(Rows.Count, 1).End(xlUp).Row
        crRow = 1
        For i = 2 To maxRow        
            '検索語と比較する文字列の作成
            buf = .Cells(i, targetCol)

            If InStr(buf, sheetName) > 0 Then
                crRow = crRow + 1
                .Rows(i).Copy newWS.Rows(crRow)
            End If
        Next
    End With

フィルターかけると言いつつ、該当列に検索語が含まれるかを1行1行判定しているだけというのは内緒。

でも色々と条件が加わったりする場合は、用意されているAutoFilterより柔軟に使えたりします。

ファイルのダウンロード

ファイル読込_絞り込み_出力01.xlsm - Google ドライブ

上記リンク先からダウンロードしてください。

できなかったらゴメンナサイ。

諸注意

・Windowsで動作します
・デモ用なので、エラー処理とかちゃんとやってません
・自由に使っていただいて構いませんが、自己責任でお願いします
・ちょっとまて！　そんなそうびじゃ　あぶないぞ

Excelで入力規則ドロップダウンリストに他シートの列名を指定する とか

はじめに

「VBAでこんなことできますシリーズ」の続きで

なんか、csv開いて、特定の言葉でデータを絞ったものを別シートに出して、
最終的にExcelファイルかcsvで出力できるみたいの

を作ろうと思ったら途中で色々あって、それなりに時間も使ってしまったので、ひとまず記事にしてみます。

VBAで入力規則ドロップダウンのリストを設定する

csvシートに、テストデータ・ジェネレータさんで生成された住所データがあります。（実在しない人たちのデータです）

csvシート

この1行目の「NO、 名前。。。」という部分を
他のシートのセルの入力規則として設定するためのコードはこちらです。

Sub 検索列入力リスト設定()
    Dim maxCol As Long
    Dim rng As Range
    With ThisWorkbook.Sheets("csv")
        maxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        If maxCol < 1 Then
            Exit Sub
        Else
            Set rng = .Range(.Cells(1, 1), .Cells(1, maxCol))
        End If
    End With
    
    With ThisWorkbook.Sheets("テスト").Range("B2").Validation
        .Delete
        .Add Type:=xlValidateList, _
             Operator:=xlEqual, _
             Formula1:="=csv!" & rng.Address
    End With
End Sub

無事、下のように出てきました。
（「テスト」というシートのB2セルです）

ドロップダウン

対象列に該当の言葉を含むセルがいくつあるかを動的に表示させてみようかしら（VBAのイベントとか使わずに）

ここが結構難しかったです。

VBAerは何でもVBAで解決したがるから複雑な関数とか実は苦手

というのはわりとあるあるかなと思うんですが、どうでしょう。

まあ、言い訳ですか。。。

数式とか

• COUNTIFを使えば、部分一致での件数を表示させることができるけど範囲指定を動的にって？？？
• INDIRECTを使えばセル上に表示されている文字列をアドレスとして関数に入れられる（らしい）
• てことはセル上に「csv!列名:列名」て出せればいいんだろうが！

試行錯誤と謎の逆ギレの末、上のように色々組み合わせるとできることがわかりました。

下のようになっているcsvシートのK列（住所）に検索語である「北海道」を
含むセルがいくつあるかを表示しています。

csvシート再掲

。。。。。。。。。。。。。。。。

ここまでやんなきゃいかんのかな。

もっといいやり方あるのかもしれませんが、まあできたのでよし。

こんなん出ました

検索列を変更したところ

検索語を変更しても変わります（当たり前）

検索語を変更したところ

GASでメール本文から銀行口座の情報をゲットする（自分用）

自分用トリアーエズ。
正規表現とかかなり怪しい（例外のほうが多いかも）

色々試して大丈夫そうなら、いずれちゃんと記事に。。。なるかなあ

BankCode API使用
https://bankcode-api.appspot.com/

var mySpreadSheet = SpreadsheetApp.getActiveSpreadsheet();
var mailSheet = mySpreadSheet.getSheetByName('メール');
var infoSheet = mySpreadSheet.getSheetByName('口座情報');

function screeningMailData(){
  var len = mailSheet.getLastRow();
  var range = mailSheet.getRange(2,1,len,5);
  var values = range.getValues();
  var newValues = [];
  var cnt = -1;
  var mailBodyCol = 4;

  for(var i=0;i<len;i++){
    var mailStr = values[i][mailBodyCol - 1];
    var codeNumStr = getCodeNumStr(mailStr);
    if(codeNumStr!=''){
      cnt++;
      newValues[cnt] = [];
      newValues[cnt] = values[i];
      
      var bankName = getBankName(mailStr);
      newValues[cnt][5] = bankName;      
      newValues[cnt][6] = getBankCode(bankName);
    
      var branchName = getBranchName(mailStr);
      newValues[cnt][7] = branchName;   
      newValues[cnt][8] = getBranchCode(newValues[cnt][6], branchName);
      
      newValues[cnt][9] = codeNumStr;
      newValues[cnt][10] = getKatakanaName(mailStr);
    }
　}      
  infoSheet.getRange(2,1,cnt + 1,newValues[1].length).setValues(newValues);  
}

//口座番号
function getCodeNumStr(mailStr){
  var re = /\d{7}/;
  var myArray = mailStr.match(re);
  if (myArray == null){
    return '';
  }
  return myArray[0];
}

//銀行名
function getBankName(mailStr){
  var re = /\n.{1,5}銀行/;
  var myArray = mailStr.match(re);
  if (myArray == null){
    return '';
  }
  var str =  myArray[0];
  str  = str.replace(/\r?\n/g, '');  //改行を消去
  return str ;
}

//銀行コード
function getBankCode(bankName){
  bankName = bankName.replace('銀行','');
  var url = 'https://bankcode-api.appspot.com/api/bank/JP?name=' + bankName;
  Utilities.sleep(1000);  //短時間に何度もアクセスしないように
  try{
    var response = UrlFetchApp.fetch(url);
    var content = response.getContentText('UTF-8');
    var obj = JSON.parse(content);
    var info = obj['data'][0]['code'];
  }catch(e){
    return '';
  }
  return info;
}

//支店名
function getBranchName(mailStr){
  var re = /[^ 　）)\n]{1,5}支店/;
  var myArray = mailStr.match(re);
  if (myArray == null){
    return '';
  }
  return myArray[0];
}

//支店コード
function getBranchCode(bankCode, branchName){
  if (bankCode=='' || branchName==''){    
    return '';
  }
  branchName = branchName.replace('支店','');
  var url = 'https://bankcode-api.appspot.com/api/bank/JP/' + bankCode + '?name=' + branchName;
  Utilities.sleep(1000);  //短時間に何度もアクセスしないように
  try{
    var response = UrlFetchApp.fetch(url);
    var content = response.getContentText('UTF-8');
    var obj = JSON.parse(content);
    var info = obj['data'][0]['code'];
  }catch(e){
    return '';
  }
  return info;
}

//口座名義
function getKatakanaName(mailStr){
  var re = /[ァ-ヴ]{1,10}\x20[ァ-ヴ]{1,10}/;
  var myArray = mailStr.match(re);
  if (myArray == null){
    return '';
  }
  return myArray[0];
}

VBAでこんなことできます_その１ フォルダ作成

イントロ

どうもinageです。
最近はRPAとかを中心に業務自動化であれこれやっております。

RPAとかGASとかIFTTTとか、手作業でやっていたことを自動化できる仕組みが色々あって、便利な世の中ですね。

たまに理解のある現場だと「VBAで良くないっすか」という意見が通ったり、運が良いと「じゃあちょっと教えてよ」と言われることもあって嬉しい限りです。

そんな時、「VBAでこんなことできます」ととりあえず見せて「おー」と言ってもらいたい。

何も準備がない時にすぐに見せられるものがあればいいな、ということで久しぶりにこのブログを思い出しました。

が

あんまり見せられるものがない。。。

で

簡単なもので、どんなことができるかわかるようなものをほぼ自分のためにいくつか上げていきたいとおもいます。

どんなマクロ

フォルダを選択して、その配下にサブフォルダを一括で作ります。

フォルダ作成マクロ

使い方

１）フォルダ選択ボタン-> フォルダを選択する
２）B７以下に作りたいサブフォルダ名を入力していく
３）フォルダ作成ボタンを押す

コード

Option Explicit

Sub フォルダ選択()
    Dim r As Range
    Set r = Sheets(1).Range("B2")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = ActiveWorkbook.Path
        If .Show = True Then
            r = .SelectedItems(1)
        End If
    End With
End Sub

Sub フォルダ作成()
    Dim rootPath As String
    Dim i As Long
    Dim maxRow As Long
    Dim folderName As String
    Dim fullPath As String
    Const startRow = 7
    
    rootPath = Range("B2")
    If Dir(rootPath, vbDirectory) = "" Then
        MsgBox "フォルダを選択してください"
        End
    End If
    
    maxRow = Cells(Rows.Count, 2).End(xlUp).Row
    If maxRow < startRow Then
        MsgBox "サブフォルダ名をB列に1つ以上入れてください"
        End
    End If
    
    For i = startRow To maxRow
        folderName = Cells(i, 2)
        fullPath = rootPath & "¥" & folderName
    '    Debug.Print i & "_" & fullPath
        If Dir(fullPath, vbDirectory) = "" Then
            MkDir fullPath
        End If
    Next
    
End Sub

ファイルのダウンロード

フォルダ作成01.xlsm - Google ドライブ

上記リンク先からダウンロードしてください。

できなかったらゴメンナサイ。

諸注意

・Windowsで動作します
・デモ用なので、エラー処理とかちゃんとやってません
・自由に使っていただいて構いませんが、自己責任でお願いします
・バナナはおやつに入りません