« Google Earth の Install 時に1603 というエラー発生 | Main | ココログでソースコードを見栄え良く掲載するには・・・ »

04/08/2016

Web天気予報を使って(中山道)トレッキング日程検討用ツールシート

Webクエリを使い連続した地域の天気予報を入手するマクロ(前回紹介したもの)を、更に改良してみた。
・これを使えば、トレッキングルート上の道標をとおる時刻と、その時の天気予報がどうなるかを組み合わせて見る事が出来る。
・下表で、左部分は、地域と天気予報を組み合わせたもので、右側部分は道標とその場所を歩く予定時刻が記載されて居る。
Photo_2

























《これを活用する場合の準備内容》

①事前に、トレッキングルート上の基準位置に対して、そこからの各ポイント迄の歩行距離と時間を一覧にしておく。 
Photo_3
 























添付した私のExcel表では、基準位置から各道標ポイント迄の距離と、その距離を歩行するに要する時間は、GoogleMapを使って求めた。
②マクロを実行させて、添付のような結果を得るためには、
 ・第1列:地域名(これは、使用者のデータ作成の間違いを防止するために入れるもので、計算では使わない)
 ・第2列:日本気象協会の天気予報を直接Webから読み取るためのデータで、天気予報を得るに一番適したその地域用のURLを作って入れる。
 ・第3列(C列)から第42列(AP列)迄を空欄にしておく。(ここに天気の状態が書き込まれる。)
 ・第43列(AQ列)から後ろ側の記載方法は任意であるが、私のやり方では、
  第43列(AQ列)に道標の名前
  第44~45列(AR~AS列)は、事由記載項目
  第46列(AT列):GoogleMapで求めた2地点間歩行距離
  第47列(AU列):GoogleMapで求めた2地点間歩行時間
  第48列(AV列):ある一日の基点からの累積距離(第46列の累積値)
  第49列(AW列):ある一日の基点からの累積時間(第47列の累積値)
  第50列(AX列):ある一日の基点のスタート時刻値から累積した予想到達時刻
  第51列(AY列):ある一日の実時刻記入欄
  第52列(AZ列):その位置の標高値(計算では使っていない。参考値の記載)
  第53列(BA列)以降は、事由記載のコメント欄など。

 再計算を行う際には、必ず 第3列(C列)から第42列(AP列)迄を空欄にすること。
 Webから入手したデータは、1地域データを読み込んだあと、(第101行、第61列)から右下の領域に書き込み作業を行う。
 一行の作業が終了した際には、同じ領域を次のデータのための作業領域として使う為に、第BE列から第BO列までを削除している。

 得られた結果は、ユーザーが指示した天気予報地域別に、一日を4分割した6時間毎の天気予報データを10日間分にわたり表示したものが一覧表になり。ユーザーが予め準備したトレッキング位置、時刻と突き合わせる事が出来る。

 これにより、いつ頃雨に降られる可能性があるか・・・、雨天を避けてトレッキングするためには、どのように日程を組めば良いかが分かりやすくなる。

《Download》
下記よりExcelデータ(含Macro)がダウンロードできる。
「weather_forecast_trek_schedule_cmbined_sheet_20160412.xlsm」をダウンロード

《ファイルの更新内容》
2016/04/10:
空欄列を一部非表示としていた為、全列表示に修正。
2016/04/12:10日目の天気予報が未だ発表されていない場合、処理が停まってしまうので、マクロを修正した。

《マクロ》

Sub WeatherScraper()

Dim i As Long, j As Long, k As Long, m As Long
Dim imax As Long, jmax As Long
Dim URLR As String
Dim URL As String, URLS As String
Dim charlen As Range
Dim killrow1 As Long, killrow2 As Long
Dim rain As Integer   '雨の際のセルの色を付けるため 雨⇒20 雨天以外は色無し⇒0
Dim rainhard As Integer   '雨量が多く設定色番号 33 を使うときの雨量(現在設定は 2㎜以上) 
Dim qrainstr As String, qrainnbr As String, qrain As Long   'qrainstr は降水量セルに書かれた文字、qrain は降水量

jmax = 50       '天気予報記載行数 = 1日5行で10日分なのでその合計 50行
rainhard = 2   
'多降水量と設定[濃い青 33]にする数値

i = 1
URLR = ""   


label1:
'同じ(重複する)エリアについてWebからデータ読み込みを行わせないようにするための処置。
If URLR = Range(Cells(i + 2, 2).Address) Then
GoTo label2
Else

'作業エリアを、次の処理のため削除する。
Range("BE:BO").Delete   

End If

'天気予報のURLをセットする。
URLR = Range(Cells(i + 2, 2).Address)

If Cells(i + 2, 2) = "" Then 

'B列のデータが無くなれば、処理を終了する。
GoTo label9
Else
'URL用データが有る限り、Webからデータを読む為の処理。 
URLS = "URL;http://" & URLR
End If
 

With ActiveSheet.QueryTables.Add(Connection:= _
  URLS, _

  Destination:=Range(Cells(101, 61).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   

 
'天気表示のセル内での二重表現部分を変更する。 
For j = 1 To jmax       
   Set charsell = Range(Cells(101 + j, 62).Address)       
   csell = Len(charsell)  'セル内の文字数を数える。 
   If csell Mod 2 = 0 Then       
   csel2 = csell / 2       '二重に書いているので数値を半分にする。 
   dadd = charsell.Value   'セルに書かれている文字データ 
   sadd = Mid(dadd, 1, csel2)    'セル枠に書かれている文字の前半分   
'セル内の文字が二重表示か否かの判定をして、二重表現ならセル内の文字は前半分にする。 
   Range(Cells(101 + j, 62).Address).Value = sadd
   Else       
   End If
Next j   

label2:

'セルの中を調べて、『雨』という文字が含まれていたら関連するセルを『青』で塗りつぶす。
For j = 1 To 10
For k = 1 To 4

rain = 0

If WorksheetFunction.CountIf(Range(Cells(103 + (k - 1) + 5 * (j - 1), 62).Address), "*雨*") Then   
  rain = 20
  Else
  rain = 0
End If 

'降水量が書き込まれたセル[qrainstr]には、文字形式で「2㎜」などと書かれている。
'全角1文字[㎜]の左側の文字を数値[qrain]にして、rainhard 以上なら青い色を濃い青 33 にする。
qrainstr = Range(Cells(103 + (k - 1) + 5 * (j - 1), 65).Address)
If InStr(qrainstr, "㎜") = 0 Then
If j = 10 Then GoTo label3
GoTo label9

End If 

qrainnbr = Left(qrainstr, InStr(qrainstr, "㎜") - 1)

qrain = Val(qrainnbr)
If qrain >= rainhard Then
rain = 33
Else
End If

label3:
If i = 1 Then
'最初のみ日付と時刻を書き入れる。
'セルの書式、セルの結合をしておく。
Cells(1, 3 + 4 * (j - 1)) = Cells(102 + 5 * (j - 1), 61)
Cells(1, 3 + 4 * (j - 1))
.NumberFormatLocal = "G/標準"
Range(Cells(1, 3 + 4 * (j - 1)), Cells(1, 6 + 4 * (j - 1))).Merge
   

Cells(2, 3 + (k - 1) + 4 * (j - 1)) = Cells(103 + (k - 1) + 5 * (j - 1), 61)
Cells(2, 3 + (k - 1) + 4 * (j - 1))
.NumberFormatLocal = "hh:mm"

Else
End If

'関連するセルの色を変更する処理
For m = 1 To 6   
   Cells(103 + (k - 1) + 5 * (j - 1), 61 + m).Interior.ColorIndex = rain
Next m   

Cells(2 + i, 3 + (k - 1) + 4 * (j - 1)).Interior.ColorIndex = rain
Cells(2 + i, 3 + (k - 1) + 4 * (j - 1)) = Cells(103 + (k - 1) + 5 * (j - 1), 62)   

Next k

Next j

'B列のデータが有る限り処理する為カウンターを1つ進めて、最初の処理点に戻す。
i = i + 1

GoTo label1


label9:
imax = i - 1

'直ぐに必要としないデータ領域を非表示にする。

Columns("B").Hidden = True
Columns("AR").Hidden = True
Columns("AS").Hidden = True
Columns("BA").Hidden = True
Columns("BB").Hidden = True
Columns("BC").Hidden = True

'セルの文字配置を中央に揃える
Range("C:AP").HorizontalAlignment = xlCenter

End Sub

« Google Earth の Install 時に1603 というエラー発生 | Main | ココログでソースコードを見栄え良く掲載するには・・・ »

PC and PC troubles」カテゴリの記事

Comments

Post a comment

Comments are moderated, and will not appear on this weblog until the author has approved them.

(Not displayed with comment.)

TrackBack

TrackBack URL for this entry:
http://app.cocolog-nifty.com/t/trackback/540128/63456367

Listed below are links to weblogs that reference Web天気予報を使って(中山道)トレッキング日程検討用ツールシート:

« Google Earth の Install 時に1603 というエラー発生 | Main | ココログでソースコードを見栄え良く掲載するには・・・ »

April 2017
Sun Mon Tue Wed Thu Fri Sat
            1
2 3 4 5 6 7 8
9 10 11 12 13 14 15
16 17 18 19 20 21 22
23 24 25 26 27 28 29
30            

Recent Trackbacks

無料ブログはココログ