Webの10日間天気予報をExcelに書き写し編集する
日本気象協会の10日間天気予報のWebページのデータを写し取り、複数の場所のURLデータを一覧にして、天気の状況の変化をみるための処理を行う。Webページの表現方法が変更になって、以前作成したマクロでは処理が出来なくなっていたので見直す事にした。しばらくぶりに見るマクロで、処理をどのように書いていたか、思い出すのに一苦労した。
データ処理のマクロは、下記のようになる。
Webデータを書き写す際の間違いに気づいたので、今回はここも修正した。
「日本気象協会の10日間天気予報」を活用した、以前僕が発表したマクロは、今回発表のマクロ(下記)に変更して欲しい。
《注記》下記マクロの第80,84行目にCell位置指示の間違いが有ったので修正した。(2017/10/04)
《マクロ部分》
Sub WeatherScraper() 'URL内の記載状況が変わったため、マクロを見直し新バージョンとして作成(2017/09/28) Dim i As Long, j As Long, k As Long, imax As Long Dim URL As String, URLSet As String Dim charsell As String, dadd As String, sadd As String Dim nsell As Long, hnsel As Long '雨の際のセルの色を付けるため 雨⇒20 雨天以外は色無し⇒0 Dim rain As Integer '雨量が多く設定色番号 33 を使うときの雨量(現在設定は 2㎜以上) Dim rainhard As Integer 'qrainstr は降水量セルに書かれた文字、qrain は降水量 Dim qrainstr As String, qrainnbr As String, qrain As Long '多降水量設定にする数値 僕は2mmとした。 rainhard = 2 ' i: URLとして書かれた処理入力番号 i = 1 'URLが書かれたセル内にデータがある間処理を続ける。 Do Until Cells(i + 2, 2) = "" 'URLの読み込み位置にデータが存在しているので、天気予報のURLをセットする。 URLSet = "URL;" & Range(Cells(i + 2, 2).Address) 'WebからExcelシート内にデータを書き写す位置の記載方法が間違っていたので 'Destinationの中の表現を修正した。 With ActiveSheet.QueryTables.Add(Connection:= _ URLSet, _ Destination:=Range(Cells(101, 53 + (i - 1) * 7).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 'WebからExcelに書き写した表データ部分から、 '新たな表作成に必要なデータ部分をピックアップしてC列から右側に表記する。 If i = 1 Then '先ず、日・曜日を転記する。日と曜日のデータは、"BA"列に書き写してあり、 ' 102,109,116,123,130, 140,147,154,161,168に記載されている。 ' これを、列 3,7,11,・・・ となるので ⇒ 3+(J-1)*4 に転記する。 For j = 1 To 5 Cells(1, 3 + (j - 1) * 4) = Cells(102 + (j - 1) * 7, "BA") Next j For j = 6 To 10 Cells(1, 3 + (j - 1) * 4) = Cells(102 + 3 + (j - 1) * 7, "BA") Next j '次に時間枠(3:00,9:00,15:00,21:00)を転記する。 For j = 1 To 5 For k = 1 To 4 Cells(2, 3 + (k - 1) + (j - 1) * 4) = Cells(105 + (k - 1) + (j - 1) * 7, "BA") Next k Next j For j = 6 To 10 For k = 1 To 4 Cells(2, 3 + (k - 1) + (j - 1) * 4) = Cells(105 + 3 + (k - 1) + (j - 1) * 7, "BA") Next k Next j '日付と時刻を見やすくするため、セルの書式、セルの結合をしておく。 For j = 1 To 10 Cells(1, 3 + 4 * (j - 1)).NumberFormatLocal = "G/標準" Range(Cells(1, 3 + 4 * (j - 1)), Cells(1, 6 + 4 * (j - 1))).Merge Range(Cells(1, 3 + 4 * (j - 1)), Cells(1, 6 + 4 * (j - 1))).HorizontalAlignment = xlCenter For k = 1 To 4 Cells(2, 3 + (k - 1) + 4 * (j - 1)).NumberFormatLocal = "hh:mm" Next k Next j End If '天気に対するコメント、最初のデータはBB列(54列)より(晴れ、曇りなど)を転記する。 'ここからは、URLを読んだ数毎に、読込み列は+7する必要がある。 'Webから写し取ったセル内の天気コメントは、全て二重表現になるので、文字数を1/2にする。 For j = 1 To 5 For k = 1 To 4 charsell = Range(Cells(105 + (k - 1) + (j - 1) * 7, 54 + (i - 1) * 7).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(105 + (k - 1) + (j - 1) * 7, 57 + (i - 1) * 7).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), 3 + (k - 1) + (j - 1) * 4) = sadd Cells(3 + (i - 1), 3 + (k - 1) + (j - 1) * 4).Interior.ColorIndex = rain Next k Next j '基本的に1~5日目までの処理と同じだが、記載されている場所が違うので別処理とした For j = 6 To 10 For k = 1 To 4 charsell = Range(Cells(105 + 3 + (k - 1) + (j - 1) * 7, 54 + (i - 1) * 7).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(105 + 3 + (k - 1) + (j - 1) * 7, 57 + (i - 1) * 7).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), 3 + (k - 1) + (j - 1) * 4) = sadd Cells(3 + (i - 1), 3 + (k - 1) + (j - 1) * 4).Interior.ColorIndex = rain Next k Next j 'B列のデータが有る限り処理する為カウンターを1つ進めて、最初の処理点に戻す。 i = i + 1 Loop imax = i - 1 '直ぐに必要としないデータ領域を非表示にし、Webから写し取ったセル部分を削除する。 Columns("B").Hidden = True Range(Columns(53), Columns(53 + imax * 7)).Delete End Sub
《注記》
ここで、もしWebから転記した生データを確認したいのなら、このマクロの「Range(Columns(53), Columns(53 + imax * 7)).Delete」部分をコメント行にすればよい。そうすれば、第53列目から後半の列に、転記されたデータを見る事が出来る。
《Excelシートの書き方》Excelシートの書き方の事例を記載する。
①先ず、Google検索で
「日本気象協会 10日間天気予報 青森県」をキーワードにして、該当するURLを検索する。
②検索された一覧より、
『青森市の10日間天気(6時間ごと) - 日本気象協会 tenki.jp』 を選ぶ。ここでのポイントは、(6時間ごと)というキーワードが入っているものを選ぶこと。
③②で選んだ画面を開き、URLをコピーする。
この例では、『https://tenki.jp/forecast/2/5/3110/2201/10days.html 』となっている。
10日間天気予報のデータが含まれているという事を htmlの直前に書かれている 10days で確認しておく。
④これを、ExcelシートのB列に貼り付ける。
貼り付ける順番は、自分が訪問したい場所順に、第1番目の訪問場所のURLは3行目に、第2番目の訪問場所は4行目に記載、・・・。必要な訪問場所を順番に貼り付ける。
⑤天気予報を確認したい場所のURL貼り付けが終われば準備完了である。
マクロは、B列にデータが無くなれば処理を終了するようになっている。
・C列からAP列に処理結果が記載され、WebからこのExcelシート内に転記したデータは消去するようにしてある。
・C列からAP列のセル幅は、標準値になっているので、見やすくするために列幅の自動調整をするのが良い。
⑥A列の第3行目以降は、URLの説明書きとして使用するのが良い。
また、AQ列~AZ列もコメント書きに使用することが出来る。
⑦マクロを実行させた上記のデータでの結果(2017/10/01 23:00処理)は、下記のようになった。(ご参考)
《表示結果をより見易くするために》 2017/10/04追記
①表の幅をデータの文字長さに合わせて、C列からAP列までを自動調整する。
②表のC1から第42列(AP列)の第(imax+2)行まで罫線を引く。
③②のセル中のデータは、セルの幅方向の中央に置く。
これを行うためには、上記マクロの第184行のところに、下記のマクロを挿入すればいい。
'表の幅をデータの文字長さに合わせて自動調整する。 '範囲は、C列からAP列まで Range("C:AP").Columns.AutoFit '表の罫線を引く。 '罫線を引く範囲は、C1から第42列(AP列)の第(imax+2)行まで Range(Cells(1, 3), Cells(imax + 2, 42)).Borders.LineStyle = xlContinuous 'セルの中のデータは幅方向の中央に置く Range(Cells(1, 3), Cells(imax + 2, 42)).HorizontalAlignment = xlCenter
« 燧ケ岳登山と御池古道を歩く計画 | Main | 大清水から尾瀬・燧ケ岳 日帰り登山 »
「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.
Comments