« VBAとExcel Webクエリを使い複数地域の天気予報を入手する | Main | Webクエリを使い連続した地域の天気予報を入手するマクロ 最終 »

04/02/2016

Webクエリを使い連続した地域の天気予報を入手するマクロ

先日、掲載したブログ『VBAとExcel Webクエリを使い複数地域の天気予報を入手する』を、マクロを使って自動的にExcelの表に纏める事が出来たので、ここに記載しておく。

特別な処理はしていないと思うが、このマクロを使って確認した条件は、
①Windows10 64bit OS
②Microsoft Office 2010 の中のExcel
③Excel の
WorkSheet には、左記の形のデータを「Sheet3」に作成しておき、Sheet4」をこの結果を記載できるように準備した。
④マクロは、Sheet3 が表示されている(Active な状態
)で起動させる。
 結果は、Sheet4 に作成される。

⑤地域データを変更したければ、添付するExcelシート(Sheet1,Sheet2)から必要な部分をコピーして、Sheet3 を作り 実行すれば良い。
⑥最終結果の表(Sheet4)は、直ぐに見ないデータ列は非表示としてあるので、必要に応じて再表示すれば良い。
⑦下図は、マクロを使って処理した結果(それ以外の手作業は行っていない)を示す。
添付図では、なるべく沢山の情報を見られるようにズーミングしている。文字が小さく、データも右側は枠から飛び出しており読めないかもしれない。
ただし、このマクロを使えば、ここまで出来ることが分かると思う。
10web

「nakasendo_weather_webquery.xlsm」をダウンロード

下記にそのVBAマクロを掲載する。上記ファイルをダウンロードすれば、マクロも含まれている。
ダウンロードした後、
①「Sheet3」を開き、⇒「開発」タグをクリックし、⇒「Visual Basic」のアイコンをダブルクリックすると、マクロが表示される。
②ツールバーアイコンの中から「
」ボタンをクリックすれば、このマクロを実行できる。


この表を作成するに際し、いろいろなテクニックを調べ・使って作成したので、その内容は併記してあるコメントを見れば容易に分かると思う。また、別の用途でも参考になると思う。

Sub WeatherScraper()
'マクロの起動は、天気予報を求めるURLデータを記載した Sheet3 を開き実行すること。
'Sheet4 が設定されていること。但し、その中のデータはこのマクロで全て削除されて使われるので、要注意!


Dim i As Long, j As Long, k As Long
Dim imax As Long, jmax As Long
Dim URLR As Range
Dim URL As String
Dim AreaR As Range
Dim Area As String
Dim daddR As Range
Dim dadd As String
Dim charsell As Range
Dim csell As Long, csel2 As Long
Dim saddR As Range
Dim sadd As String
Dim charlen As Range
Dim killrow1 As Long, killrow2 As Long
Dim sh1 As Worksheet, sh2 As Worksheet

imax = 12   '天気予報情報を読み取る数
jmax = 50   '天気予報記載行数 = 1日5行で10日分なのでその合計 50行
killrow1 = 72  '不要行記載部分の開始行
killrow2 = 132 '不要行記載部分の終了行

For i = 1 To imax
  '天気予報URLの地域名を Area に格納する。
     Set AreaR = Range(Cells(i + 1, 2).Address)
     Area = AreaR.Value

  '天気予報のURLをセットする。
     Set URLR = Range(Cells(i + 1, 3).Address)
     URL = "URL;http://" & URLR.Value

  'Excelの Webクエリで天気予報情報を読み取り、Sheetの(F20から)右下部分に書き取る。
     With ActiveSheet.QueryTables.Add(Connection:= _
     URL, _
     Destination:=Range(Cells(21, 7 * (i - 1) + 1 + 5).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

'天気予報の地域名を天気表示列の最上部に記載する。

     Range(Cells(20, 7 * (i - 1) + 2 + 5).Address).Value = Area

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

'不要な行の削除 (killrow1 から killrow2 迄を削除)
     Rows(killrow1 & ":" & killrow2).Delete  

'列の幅を自動調整する。
     For i = 1 To imax
     Range(Columns(7 * (i - 1) + 6).Address, Columns(7 * (i - 1) + 6 + 7).Address).Columns.AutoFit
     Next i

'不要な列の削除 (削除列は先頭列にダブる情報なので削除する)
'削除は列番号が変わらないようにするため、最右列データ部分から左列データ方向に削除  


For k = 1 To (imax - 1)
    Range(Columns(7 * (imax - k) + 6).Address).Delete
Next k  

'データを現 Sheet3 から Sheet4 にコピーする。(シートの定義)
Set sh1 = Worksheets("Sheet3")
Set sh2 = Worksheets("Sheet4")

'先ず、 Sheet4 のすべてのセルの内容を削除
Range("A1").Clear
'Sheet3 の天気予報データの内容を Sheet4 にコピーする。
  sh1.Range(Cells(20, 6).Address, Cells(killrow1 - 1, 7 * (imax - 1) + 6 + 7).Address).Copy _  
  Destination:=sh2.Range("A1")

'Sheet3にWebクエリで作ったデータ部分を削除する。
'不要な行の削除 (20行目から(killrow1-1)行目迄を削除)

   Rows(20 & ":" & (killrow1 - 1)).Delete

'Sheet4 に作業を移して
   sh2.Activate

'直ぐには 使わない/見ない 不要列を非表示にする。
'表示するのは「日付」「天気」「降水確率」「降水量」で、それ以外のデータは非表示とする。
'天気のみの表示とするためには、下のマクロで column(4・・・, column(5・・・,を他と同様に記載し追加する。

For i = 1 To imax
Columns(3 + 6 * (i - 1)).Hidden = True
Columns(6 + 6 * (i - 1)).Hidden = True
Columns(7 + 6 * (i - 1)).Hidden = True
Next i

'地域の範囲を明確にするため、地域名記載の該当するセルを結合する。

For i = 1 To imax
Range(Cells(1, 2 + 6 * (i - 1)), Cells(1, 7 + 6 * (i - 1))).Merge
Next i

'データ部分に格子罫線を引く データセルは A1 から Cell(52,7*(imax-1)+1) まで
For i = 1 To imax
Range(Cells(1, 1), Cells(5 * 10 + 2, 7 + 6 * (i - 1))).Borders.LineStyle = xlContinuous
Next i

End Sub

« VBAとExcel Webクエリを使い複数地域の天気予報を入手する | Main | Webクエリを使い連続した地域の天気予報を入手するマクロ 最終 »

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/63428834

Listed below are links to weblogs that reference Webクエリを使い連続した地域の天気予報を入手するマクロ:

« VBAとExcel Webクエリを使い複数地域の天気予報を入手する | Main | Webクエリを使い連続した地域の天気予報を入手するマクロ 最終 »

June 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

無料ブログはココログ