VBAでAKB48の各チームの平均年齢が最も若いチームはどのチームか計算

VBA

AKB48メンバーの公式サイト

AKB48公式サイト | メンバー
AKB48公式サイト | メンバー
www.akb48.co.jp

HTML要素の見方

ChromeでAKB48メンバーの公式サイトを開く、ブラウザが開いた状態にF12を押し、デバグモードが表示される。そこで、HTML要素を検証するボタンを押すか[Ctrl+Shift+C]を押す。

VBAでDocument Object Model (DOM) を取得する

纏めたい情報をExcelのフォーマットを作成

VBAエディタでソースコードを入力

  • VBAエディタを開く [Alt+F11]を押すか或いはMenu＞開発＞Visula Basicを押す
  • 標準モジュールを作成
  • ツール＞参照設定＞Microsoft Internet Controlsを追加
  • ツール＞参照設定＞Microsoft HTML Object Libraryを追加
Sub getAKBMember()

    Dim objIE As InternetExplorer
    Dim htmlDoc As HTMLDocument
    Dim wb As Workbook
    Dim sh As Worksheet
    
    Set wb = ThisWorkbook
    Set sh = ActiveSheet
    
    sh.Range("B3:H10000").ClearContents
    
    Set objIE = New InternetExplorer
    
    objIE.Visible = True
    objIE.navigate "https://www.akb48.co.jp/about/members"
    
    'ログイン画面
    Call Wait(objIE)
    Set htmlDoc = objIE.document
    Index = 1
    
    For Each Item In htmlDoc.getElementsByClassName("memberList")
        If sh.Range("C3").Value = "" Then
            tempRow = 3
        Else
            tempRow = sh.Range("C2").End(xlDown).Row + 1
        End If
        
        sh.Cells(tempRow, 2).Value = Index
        
        sh.Cells(tempRow, 3).Value = Item.Children(0).Children(1).Children(0).innertext
        
        sh.Cells(tempRow, 4).Value = Item.Children(0).Children(1).Children(1).innertext
        
        sh.Cells(tempRow, 5).Value = Item.Children(0).Children(0).Children(0).src
        ActiveSheet.Hyperlinks.Add Anchor:=sh.Cells(tempRow, 5), Address:=sh.Cells(tempRow, 5).Value, TextToDisplay:=sh.Cells(tempRow, 5).Value
        
'        strFname = "https://s.akb48.co.jp/upload/images/d5e3666afcbed98b781932dc5008d60c.jpg"
'
'        With sh.Cells(tempRow, 5)
'            Set objShape = ActiveSheet.Shapes.AddPicture( _
'            Filename:=strFname, LinkToFile:=False, _
'            SaveWithDocument:=True, Left:=.Left, _
'            Top:=.Top, Width:=100, Height:=100) 'サイズ１で貼り付け
'
'
'            With objShape
'                .LockAspectRatio = msoTrue
'                .ScaleHeight 1, msoTrue
'                .ScaleWidth 1, msoTrue
'
'                '画像サイズをセルの幅、高さに合わせる
'                rx = Cel_Width / .Width
'                ry = Cel_Height / .Height
'
'                If rx > ry Then
'                    .Height = .Height * ry - yohaku
'                    .Width = .Width - yohaku
'                Else
'                    .Height = .Height - yohaku
'                    .Width = .Width * rx - yohaku
'                End If
'                'セルの芯に
'                .Left = Cel_Left + (Cel_Width - .Width) / 2
'                .Top = Cel_Top + (Cel_Height - .Height) / 2
'
'             End With
'
'        End With
        
        ActiveSheet.Hyperlinks.Add Anchor:=sh.Cells(tempRow, 6), Address:=Item.Children(0).href, TextToDisplay:=Item.Children(0).href
        
        sh.Cells(tempRow, 7).Value = Item.Children(0).Children(1).Children(2).Children(1).innertext
        
        sh.Cells(tempRow, 8).Value = Item.Children(0).Children(1).Children(3).innertext
        
        Index = Index + 1
    Next

End Sub

Sub Wait(objIE As InternetExplorer)
    
    '■objIEがBusy(処理中なら)DoEventsで待機
    Do While objIE.Busy = True
        DoEvents
    Loop
    
    '■objIEがREADYSTATE_COMPLETE(全データ読込完了になるまで)DoEventsで待機
    Do While objIE.readyState <> READYSTATE_COMPLETE
        DoEvents
    Loop

    '■Frameも含めた全ての要素がcompleteになるまで待機
    Do Until objIE.document.readyState = "complete"
      DoEvents
    Loop
       
    Application.Wait Now() + TimeValue("00:00:01")
    
    'Debug.Print objIE.document.activeElement.disabled
    
End Sub

コードの説明

Excelのワークブックとワークシート定義

    Dim wb As Workbook
    Dim sh As Worksheet
    
    Set wb = ThisWorkbook
    Set sh = ActiveSheet

IEブラウザ起動

 objIE.navigate "https://www.akb48.co.jp/about/members"

AKBメンバーの全HTML要素取得

For Each Item In htmlDoc.getElementsByClassName("memberList")

AKBメンバーのHTML要素情報をExcelのセルに転記

        If sh.Range("C3").Value = "" Then
            tempRow = 3
        Else
            tempRow = sh.Range("C2").End(xlDown).Row + 1
        End If
        
        sh.Cells(tempRow, 2).Value = Index
        
        sh.Cells(tempRow, 3).Value = Item.Children(0).Children(1).Children(0).innertext
        
        sh.Cells(tempRow, 4).Value = Item.Children(0).Children(1).Children(1).innertext
        
        sh.Cells(tempRow, 5).Value = Item.Children(0).Children(0).Children(0).src
        ActiveSheet.Hyperlinks.Add Anchor:=sh.Cells(tempRow, 5), Address:=sh.Cells(tempRow, 5).Value, TextToDisplay:=sh.Cells(tempRow, 5).Value

        ActiveSheet.Hyperlinks.Add Anchor:=sh.Cells(tempRow, 6), Address:=Item.Children(0).href, TextToDisplay:=Item.Children(0).href
        
        sh.Cells(tempRow, 7).Value = Item.Children(0).Children(1).Children(2).Children(1).innertext
        
        sh.Cells(tempRow, 8).Value = Item.Children(0).Children(1).Children(3).innertext

HTML要素情報取得の待ち処理

Sub Wait(objIE As InternetExplorer)
    
    '■objIEがBusy(処理中なら)DoEventsで待機
    Do While objIE.Busy = True
        DoEvents
    Loop
    
    '■objIEがREADYSTATE_COMPLETE(全データ読込完了になるまで)DoEventsで待機
    Do While objIE.readyState <> READYSTATE_COMPLETE
        DoEvents
    Loop

    '■Frameも含めた全ての要素がcompleteになるまで待機
    Do Until objIE.document.readyState = "complete"
      DoEvents
    Loop
       
    Application.Wait Now() + TimeValue("00:00:01")
    
    'Debug.Print objIE.document.activeElement.disabled
    
End Sub

コメント

タイトルとURLをコピーしました