複数訪問予定地の天気予報(3時間と10日間を組合せ)表示
複数の離れた場所の訪問予定地がある際に、天気予報はどうなるのか調べる事があるが、何回も天気予報情報を開いて調べ、何枚もプリントし、それらを並べて漸く、自分の行動予定に伴う天気の今後の状況が把握できる。
もう少し効率的に調べて表示したいものだと思い、Excelのスクレーピング技術で表示するようにしてみた。当初は10日間天気予報のデータだけで纏めていたが、最初の3日間なら、3時間天気予報のデータを使う事が出来るので、3時間天気予報と10日間天気予報を組合せて表示させるようにしてみた。
マクロの内容は殆ど同じではあるが、3時間天気予報と10日間天気予報では、記載方法が少し違っている部分を変更してやる必要がある。(左図で表示した結果サンプルでは、データの幅が広くて画面からはみ出し、この画面では残り2日分が表示出来ていない。)
なお、場所に関するデータ(図のA~B列)の作成方法は、10日間天気予報と同じとした。3時間天気予報の部分は内部処理で補っている。
作成したマクロを以下に表示する。変更した部分は、10日間天気予報で作成したマクロと比較すれば、容易に分かると思うが、マクロの中に若干のコメントも記載したので、興味がある方には参考になると思う。
Webを読み取りExcel内に書き写した部分は、マクロの最後の部分で消去しているので、この部分をコメント表示にすれば、どのような書き写しが行われたかが分かり、参考になると思う。
尚、Excelシート内にマクロを実行するボタンを作成しておけば、便利だと思う。
《注記》 2017/10/20: マクロの記述に間違いがあり、3時間天気予報が地域別で更新されなかったのを修正した。上図では最初の3日間天気予報の表示が全て同じになってしまっているが、左の図では地域別に違った状況になっている。
《マクロ》
Sub WeatherScraper2() '3時間天気予報と10日間天気予測を組み合わせ表示するようにした(2017/10/19) Dim i As Long, j As Long, k As Long, imax As Long Dim URL As String, URLSet As String Dim URL10days As String, URL3hours As String Dim charsell As String, dadd As String, sadd As String Dim nsell As Long, hnsel As Long '雨の際のセルの色を付ける変数 rain 雨⇒20 雨天以外は色無し⇒0 Dim rain As Integer '雨量が多く設定色番号 rainhard 33 を使うときの雨量(現在設定は 2㎜以上) Dim rainhard As Integer 'qrainstr は降水量セルに書かれた文字、qrain は降水量 Dim qrainstr As String, qrainnbr As String, qrain As Long rainhard = 2 ' i: URLとして書かれた処理入力番号 i = 1 'URLが書かれたセル内にデータがある間処理を続ける。 Do Until Cells(i + 2, 2) = "" '10days.htmlから3hours.htmlを作る URL10days = Range(Cells(i + 2, 2).Address) URL3hours = Replace(URL10days, "10days", "3hours") '先ず3時間天気予報のURLをセットし、スクレーピングする。 URLSet = "URL;" & URL3hours With ActiveSheet.QueryTables.Add(Connection:= _ URLSet, _ Destination:=Range(Cells(101, 61 + (i - 1) * 9).Address)) .Name = "?kd=1&tm=d&vl=a&mk=1&p=1" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlAllTables .WebFormatting = xlWebFormattingNone .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False .Refresh BackgroundQuery:=False End With '不要な4日目以降のデータ領域を削除する。 Range(Cells(155, 61 + (i - 1) * 9), Cells(240, 70 + (i - 1) * 9).Address).Delete '次に10日間天気予報のURLをセットし、スクレーピングする。 'この際、.RefreshStyle は xlOverwriteCells とする。 URLSet = "URL;" & URL10days With ActiveSheet.QueryTables.Add(Connection:= _ URLSet, _ Destination:=Range(Cells(155, 61 + (i - 1) * 9).Address)) .Name = "?kd=1&tm=d&vl=a&mk=1&p=1" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlOverwriteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlAllTables .WebFormatting = xlWebFormattingNone .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False .Refresh BackgroundQuery:=False End With '不要なデータ領域を削除する。少し大きめの領域を削除 Range(Cells(229, 61 + (i - 1) * 9), Cells(250, 70 + (i - 1) * 9).Address).Delete 'WebからExcelに書き写した表データ部分から、 '新たな表作成に必要なデータ部分をピックアップしてC列から右側に表記する。 If i = 1 Then '先ず、日・曜日を転記する。日と曜日のデータは、61列156行目から For j = 1 To 3 Cells(1, 3 + (j - 1) * 8) = Cells(156 + (j - 1) * 7, 61) Next j For j = 4 To 5 Cells(1, 27 + (j - 4) * 4) = Cells(177 + (j - 4) * 7, 61) Next j For j = 6 To 10 Cells(1, 35 + (j - 6) * 4) = Cells(194 + (j - 6) * 7, 61) Next j '時間枠(3:00,6:00,9:00,12:00,15:00,18:00,21:00,24:00)を記載する。 'これらの値は数値なので、シリアル値に換算するため24で割る。 For j = 1 To 3 For k = 1 To 8 Cells(2, 3 + (k - 1) + (j - 1) * 8) = Cells(104, 62 + (k - 1)) / 24 Next k Next j '次に時間枠(3:00,9:00,15:00,21:00)を転記する。 'ここは文字列なので、其のまま転記すればよい。 For j = 4 To 10 For k = 1 To 4 Cells(2, 27 + (k - 1) + (j - 4) * 4) = Cells(180 + (k - 1), 61) Next k Next j '日付と時刻を見やすくするため、セルの書式設定、セルの結合を行う。 For j = 1 To 3 Cells(1, 3 + (j - 1) * 8).NumberFormatLocal = "G/標準" Range(Cells(1, 3 + (j - 1) * 8), Cells(1, 10 + (j - 1) * 8)).Merge Range(Cells(1, 3 + (j - 1) * 8), Cells(1, 10 + (j - 1) * 8)).HorizontalAlignment = xlCenter For k = 1 To 8 Cells(2, 3 + (k - 1) + (j - 1) * 8).NumberFormatLocal = "[h]:mm" Next k Next j For j = 4 To 10 Cells(1, 27 + (j - 4) * 4).NumberFormatLocal = "G/標準" Range(Cells(1, 27 + (j - 4) * 4), Cells(1, 30 + 4 * (j - 4))).Merge Range(Cells(1, 27 + (j - 4) * 4), Cells(1, 30 + 4 * (j - 4))).HorizontalAlignment = xlCenter For k = 1 To 4 Cells(2, 27 + (k - 1) + (j - 4) * 4).NumberFormatLocal = "hh:mm" Next k Next j End If '天気に対するコメントを転記する。 For j = 1 To 3 For k = 1 To 8 sadd = Range(Cells(107 + (j - 1) * 18, 62 + (k - 1)+ (i - 1) * 9).Address) If InStr(sadd, "晴れ") > 0 Then rain = 0 Else End If If InStr(sadd, "曇り") > 0 Then rain = 15 Else End If If InStr(sadd, "雨") > 0 Then rain = 20 '降水量が書き込まれたセル[qrainstr] '文字を数値[qrain]にして、rainhard 以上なら青い色を濃い青 33 にする。 qrainstr = Range(Cells(112 + (j - 1) * 18, 62 + (k - 1) + (i - 1) * 9).Address) qrain = Val(qrainstr) If qrain > 0 Then '「小雨」で、雨量が 0以上なら色は薄い水色(28)に設定する。 rain = 28 Else End If If qrain >= rainhard Then '「小雨」で、雨量がここで設定した2mm以上なら色は濃い水色(33)に設定する。 rain = 33 Else End If Else End If 'セルに天気コメントを書き入れ、そのセルの色を付ける。 Cells(3 + (i - 1), 3 + (k - 1) + (j - 1) * 8) = sadd Cells(3 + (i - 1), 3 + (k - 1) + (j - 1) * 8).Interior.ColorIndex = rain Next k Next j '天気に対するコメント、データは62列より(晴れ、曇りなど)を転記する。 'ここからは、URLを読んだ数毎に、読込み列は+9する必要がある。 'Webから写し取ったセル内の天気コメントは、全て二重表現になるので、文字数を1/2にする。 For j = 4 To 5 For k = 1 To 4 charsell = Range(Cells(180 + (k - 1) + (j - 4) * 7, 62 + (i - 1) * 9).Address) 'セル内の文字数を数える。 nsell = Len(charsell) '二重に書いているので数値を半分にする。 hnsel = nsell / 2 'セル枠に書かれている文字の前半分 sadd = Mid(charsell, 1, hnsel) If InStr(sadd, "晴れ") > 0 Then rain = 0 Else End If If InStr(sadd, "曇り") > 0 Then rain = 15 Else End If If InStr(sadd, "雨") > 0 Then rain = 20 '降水量が書き込まれたセル[qrainstr]には、文字形式で「2㎜」などと書かれている。 '全角1文字[㎜]の左側の文字を数値[qrain]にして、rainhard 以上なら青い色を濃い青 33 にする。 qrainstr = Range(Cells(180 + (k - 1) + (j - 4) * 7, 65 + (i - 1) * 9).Address) qrainnbr = Left(qrainstr, InStr(qrainstr, "㎜") - 1) qrain = Val(qrainnbr) If qrain > 0 Then '「小雨」で、雨量が 0以上なら色は薄い水色(28)に設定する。 rain = 28 Else End If If qrain >= rainhard Then '「小雨」で、雨量がここで設定した2mm以上なら色は濃い水色(33)に設定する。 rain = 33 Else End If Else End If 'セルに天気コメントを書き入れ、そのセルの色を付ける。 Cells(3 + (i - 1), 27 + (k - 1) + (j - 4) * 4) = sadd Cells(3 + (i - 1), 27 + (k - 1) + (j - 4) * 4).Interior.ColorIndex = rain Next k Next j '6日目以降の処理は、1~5日目までの処理と同じだが、転記元の場所が違うので別処理とした For j = 6 To 10 For k = 1 To 4 charsell = Range(Cells(197 + (k - 1) + (j - 6) * 7, 62 + (i - 1) * 9).Address) nsell = Len(charsell) hnsel = nsell / 2 sadd = Mid(charsell, 1, hnsel) If InStr(sadd, "晴れ") > 0 Then rain = 0 Else End If If InStr(sadd, "曇り") > 0 Then rain = 15 Else End If If InStr(sadd, "雨") > 0 Then rain = 20 qrainstr = Range(Cells(197 + (k - 1) + (j - 6) * 7, 65 + (i - 1) * 9).Address) qrainnbr = Left(qrainstr, InStr(qrainstr, "㎜") - 1) qrain = Val(qrainnbr) If qrain > 0 Then rain = 28 Else End If If qrain >= rainhard Then rain = 33 Else End If Else End If 'セルに天気コメントを書き入れ、そのセルの色を付ける。 Cells(3 + (i - 1), 35 + (k - 1) + (j - 6) * 4) = sadd Cells(3 + (i - 1), 35 + (k - 1) + (j - 6) * 4).Interior.ColorIndex = rain Next k Next j 'B列のデータが有る限り処理する為カウンターを1つ進めて、最初の処理点に戻す。 i = i + 1 Loop imax = i - 1 '表の幅をデータの文字長さに合わせて自動調整する。 '範囲は、C列からBB列まで Range("C:BB").Columns.AutoFit '表の罫線を引く。 '罫線を引く範囲は、C1から第54列の第(imax+2)行まで Range(Cells(1, 1), Cells(imax + 2, 54)).Borders.LineStyle = xlContinuous 'セルの中のデータは幅方向の中央に置く Range(Cells(1, 3), Cells(imax + 2, 54)).HorizontalAlignment = xlCenter '直ぐに必要としないデータ領域を非表示にし、Webから写し取ったセル部分を削除する。 Columns("B").Hidden = True Range(Columns(61), Columns(61 + 6 + imax * 7)).Delete End Sub
« ロボットカーを作ろう・・・ 先ず外装部分を作ってみる | Main | Google スプレッドシートでスクレーピングのトライアル1 »
「PC and PC troubles」カテゴリの記事
- NodeMCU1.0 or ESP32 Dev Module を使って 8x8 dotmatrix LEDでデジタル時計をつくる(2020.05.21)
- ガラ携Docomo のメールを PCで読む(2019.09.28)
- Linux Mint 19.1 に Virus 対応ソフト ClamAV を Install(2019.05.09)
The comments to this entry are closed.
« ロボットカーを作ろう・・・ 先ず外装部分を作ってみる | Main | Google スプレッドシートでスクレーピングのトライアル1 »
Comments