複数訪問予定地の天気予報（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列のデータが有る限り処理する為カウンターを１つ進めて、最初の処理点に戻す。
 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