Excel VBA スマレジタイムカードから出勤実績を取得する(その3)

前回のスマレジタイムカード取得はこちら

前々回のスマレジタイムカード取得はこちら

さて、この6月にスマレジタイムカードの表の構成がまたまた変わり、再びエラーが発生するようになりました。
今回変更になったのは各スタッフの情報です。賃金形態・交通費形態といった属性が追加されたようです。

結果が行数が増えてプログラムがエラーを吐いてしまったのですが。
本当は行番号決め打ちではなく、項目名を見て判定にしなければいけないのですが、こう頻繁に変更があると予測していなかったのでし

ていませんでした。今回は取り急ぎ読み込み行番号を変更して、時間のあるときにそのへん対応していこうと思います。

今回の変更点は大きくは二つ
・スマレジの変更対応
・複数店舗の読み込みに対応するため店舗データ表示時にスクロールを追加

メインのコードは以下

Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub getTMC() 

On Error GoTo ErrgetTMC

    If MsgBox("スマレジにログインしている場合はログアウトしてください。", vbOKCancel) = vbCancel Then
        Exit Sub
    End If
    
'所定のユーザー名とパスワード
    Const myUser As String = "hogehoge@munyamunya.com" → 実態に合わせて変更してください。
    Const myPass As String = "jugemjugem" → 実態に合わせて変更してください。
    Const BaseRow As Long = 1 'ソースリストの中の開始位置を指定する(元々は0,月表示が先頭行に追加されたため1に変更)
    Const ArnStart As Long = 2
    Const ArnEnd As Long = 1
    Const SourceListCellSearchRow As Long = 1 'ソースから列数を検索する行を指定
    Const ListInportStartRow As Long = 1 'ソースから取り込みを開始する行番号を指定する(当初0,表形式変更のため1に変更)
    Const ListInportStartCol As Long = 0 'ソースから取り込みを開始する列番号を指定する。
    Const ListInportEndCutCount As Long = 2 'ソースからカットする行数を指定する。(当初1,表形式変更のため2に変更)

'計算用
    Dim n As Long
    Dim n2 As Long
    Dim n3 As Long
    
'エラー検証用
    Dim ErrSpot As String

'ループカウンタ
    Dim Line As Long
    
'月と年
    Dim myYear As Integer
    Dim myMonth As Byte

'IEの起動
    Dim objTable As Object
    Dim objIE As InternetExplorer '変数を定義します。
    
'保存用workbookと取得データ処理用の変数
    Dim APL
    Dim BookS As Workbook
    
    Dim myEndRow As Long
    Dim myEndCol As Long

    Dim myRow1 As Long
    Dim myCol1 As Long
    
    Dim myAr
    Dim myArN As Long
    Dim myCandP
    
'UserForm1のハンドル
    Dim myResultBook As String
    
'以下本文

    UserForm1.Show vbModeless

    Application.ScreenUpdating = False

    UserForm1.Label1.Caption = "InternetExplorerを呼び出しています。"

    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Visible = True
    
    Sleep 100

'処理したいページを表示します。
    UserForm1.Label1.Caption = "スマレジタイムカードを読み込み中です。"
    objIE.Navigate "https://accounts.smaregi.jp/login?client_id=timecard"  '.Navigate メソッドで Yahooを表示する。


'ページの表示完了を待ちます。
    Call WaitIEComp(objIE)

    'IDとパスワードの入力&サインイン
    If objIE.LocationURL = "https://accounts.smaregi.jp/login?client_id=timecard" Then
        UserForm1.Label1.Caption = "スマレジタイムカードにログイン中です。"
        objIE.Document.GetElementsByName("identifier").Item(0).Value = myUser
        objIE.Document.GetElementsByName("password").Item(1).Value = myPass
        objIE.Document.GetElementsByName("doLogin").Item(0).Click
        Call WaitIEComp(objIE)
        
    End If
    
    UserForm1.Hide
    
    '年と月を指定して読み込む
    myYear = Application.InputBox("データを取得する年を半角整数で入力してください。", , Year(Date), , , , , 1)
    myMonth = Application.InputBox("データを取得する月を半角整数で入力してください。 " & vbCrLf & Str(myYear) & "年", , 

Month(Date) - 1, , , , , 1)
    
    UserForm1.Show vbModeless
    UserForm1.Label1.Caption = "指定された月の実績を読み込み中です。"

    objIE.Navigate ("https://timecard1.smaregi.jp/shifts/result/" & _
                GetQueryMonth(Application.WorksheetFunction.Text(myYear, "0000"), Application.WorksheetFunction.Text

(myMonth, "00")))
    
    Call WaitIEComp(objIE)
    objIE.Visible = True
    objIE.FullScreen = True
    Sleep 3000
    objIE.Document.Script.setTimeout "javascript:scrollTo(0," & objIE.Document.body.ScrollHeight & ");", 1000
    Sleep 3000
    'objIE.FullScreen = False

'テーブルオブジェクト取り込み

    Set objTable = objIE.Document.all.tags("TABLE")
    
    Sleep 200
    
    If objTable.Length = 0 Then
        MsgBox "シフト表が見つかりません。"
        GoTo ExitgetTMC
    End If
        
'取り込みする表の確認
    n = 2


    Sleep 200
    
    UserForm1.Hide
    objIE.Visible = False

    Do

        Line = Line + 1
    
        If MsgBox("取り込みする表の確認" & vbCrLf & objTable(n).Summary, vbYesNo) = vbYes Then
        
            myResultBook = objTable(n).Summary & ".xlsx"

            Set APL = CreateObject("Excel.Application")
            Set BookS = APL.Workbooks.Add
            
            UserForm1.Show vbModeless
            UserForm1.Label1.Caption = objTable(n).Summary & "を取り込んでいます。"
            
            With BookS.Worksheets(1)
            '表データの取り込み
            
                For n2 = ListInportStartRow To objTable(n).Rows.Length - ListInportEndCutCount '行数ループする。
                    For n3 = ListInportStartCol To objTable(n).Rows(SourceListCellSearchRow).Cells.Length - 1 '列数分ルー

プ
                        'APL.Visible = True
                        .Cells(n2 + 1, n3 + 1).Value = objTable(n).Rows(n2).Cells(n3).innertext
                    Next
                Next
            End With
            
            Exit Do
        Else

            n = n + 1
        End If
        
        Sleep 200
    Loop Until GetTableSummary(objTable, n) = ""
    

    If UserForm1.Visible = False Then UserForm1.Show vbModeless

'時給と交通費データの取得開始
    myCandP = GetCarfareAndPayment(objIE)

'所得したデータの処理


    UserForm1.Label1.Caption = "取り込んだデータの処理中です。"
    
    With BookS
        .Worksheets(1).Copy after:=.Worksheets(1)
        .Worksheets(1).Name = "計算前"
        .Worksheets(2).Name = "計算後"
        

'取り込んだ表形式を処理できる内容に変換する(20151201追加)
        Call PreConvList20151201(.Worksheets("計算後"))
        
    
        With .Worksheets("計算後")
        
'元範囲を確定
            myEndRow = .Columns(1).Find("出勤人数", , , , xlWhole).Row - 1
            
            ErrSpot = "GetEndCol"

            myEndCol = .Rows(BaseRow + 1).Find("計", , , , xlWhole).Column - 1

'出勤/退勤/休憩/時間の表に直す
            For myArN = BaseRow + 2 To myEndRow
                myRow1 = (myArN - (BaseRow + 2)) * 4 + (BaseRow + 2)
                .Rows(myRow1 + 1).Insert xlShiftDown
                .Rows(myRow1 + 2).Insert xlShiftDown
                .Rows(myRow1 + 3).Insert xlShiftDown
                .Cells(myRow1 + 3, 1).Value = .Cells(myRow1, 1).Value & " 時間(分)"
                .Cells(myRow1 + 2, 1).Value = .Cells(myRow1, 1).Value & " 休憩(時間)"
                .Cells(myRow1 + 1, 1).Value = .Cells(myRow1, 1).Value & " 退勤"
                .Cells(myRow1, 1).Value = .Cells(myRow1, 1).Value & " 出勤"
                myEndRow = myEndRow + 3
            Next

'処理範囲再確定
            myEndRow = .Columns(1).Find("出勤人数", , , , xlWhole).Row - 4
            

'出勤退勤休憩労働時各コマを計算
            For myRow1 = BaseRow + 2 To myEndRow Step 4
                For myCol1 = 2 To myEndCol
                
                    If .Cells(myRow1, myCol1).Value Like "*出勤中*" Then
                        .Cells(myRow1, myCol1).Value = ""
                    ElseIf Trim(.Cells(myRow1, myCol1).Value) <> "" Then

                        myAr = Split(Trim(.Cells(myRow1, myCol1).Text), " ")
                        myAr(ArnStart) = TimeValue(myAr(ArnStart))
                        myAr(ArnEnd) = TimeValue(myAr(ArnEnd))
                        
                        
                        .Cells(myRow1, myCol1).Value = myAr(2)  '出勤は所定の時間
                        .Cells(myRow1 + 1, myCol1).Value = myAr(1) '退勤は実際の時間
                        
                        If DateDiff("n", myAr(2), myAr(1)) >= 360 Then '6時間以上実労なら1時間休憩
                            .Cells(myRow1 + 2, myCol1).Value = 1
                        Else
                            .Cells(myRow1 + 2, myCol1).Value = 0
                        End If
                        

                        .Cells(myRow1 + 3, myCol1).Formula = "=((" & .Cells(myRow1 + 1, myCol1).Address & "-" & .Cells

(myRow1, myCol1).Address & ")" _
                                                        & "*24*60)-(" & .Cells(myRow1 + 2, myCol1).Address & "*60)"
                        
                    Else

                        .Cells(myRow1, myCol1).Value = 0
                        .Cells(myRow1 + 3, myCol1).Formula = "=((" & .Cells(myRow1 + 1, myCol1).Address & "-" & .Cells

(myRow1, myCol1).Address & ")" _
                                                        & "*24*60)-(" & .Cells(myRow1 + 2, myCol1).Address & "*60)"
                        .Cells(myRow1, myCol1).ClearContents
                    End If
                Next myCol1
            Next myRow1
            

'MsgBox "実労時間集計"
'実労時間の集計


            For myRow1 = BaseRow + 2 To myEndRow Step 4
                .Cells(myRow1, myEndCol + 1).Formula = "=SUM(" & .Range(.Cells(myRow1 + 3, 2), .Cells(myRow1 + 3, 

myEndCol)).Address & ")"

                myArN = .Cells(myRow1, myEndCol + 1).Value

                .Cells(myRow1 + 1, myEndCol + 2).Formula = "=FLOOR(" & .Cells(myRow1, myEndCol + 1).Address & "/60,0.5)"
                
                '時給と交通費の検索
                For n = 1 To UBound(myCandP, 2)
                    If Trim(Replace(.Cells(myRow1, 1).Value, "出勤", "")) = myCandP(0, n) Then
                        '時給
                        .Cells(myRow1 + 2, myEndCol + 2).Value = CLng(myCandP(2, n))
                        .Cells(myRow1 + 2, myEndCol + 2).NumberFormatLocal = Chr(34) & "(@" & Chr(34) & "G/標準" & Chr

(34) & ")" & Chr(34)
                        .Cells(myRow1 + 2, myEndCol + 1).Formula = "=" & .Cells(myRow1 + 1, myEndCol + 2).Address & "*" & 

.Cells(myRow1 + 2, myEndCol + 2).Address
                        
                        
                        '交通費
                        .Cells(myRow1 + 3, myEndCol + 2).NumberFormatLocal = Chr(34) & "(@" & Chr(34) & "G/標準" & Chr

(34) & ")" & Chr(34)
                        .Cells(myRow1 + 3, myEndCol + 2).Value = CLng(myCandP(3, n))
                        .Cells(myRow1 + 3, myEndCol + 1).Formula = "=Count(" & .Range(.Cells(myRow1, 2), .Cells(myRow1, 

myEndCol)).Address & _
                                                                      ")*" & .Cells(myRow1 + 3, myEndCol + 2).Address
                        
                        
                        Exit For
                    End If
                Next n

                .Range(.Cells(myRow1 + 3, 1), .Cells(myRow1 + 3, myEndCol + 1)).Borders(xlEdgeBottom).LineStyle = 

xlContinuous
            Next myRow1
            
        End With
        
    End With


    

    
ExitgetTMC:
    
    '終了前にログアウト
    UserForm1.Label1.Caption = "スマレジタイムカードからログアウトしています。"
    
    If Not objIE Is Nothing Then objIE.Navigate ("https://accounts.smaregi.jp/logout")
    If Not BookS Is Nothing Then
        BookS.Close savechanges:=True, Filename:=ThisWorkbook.Path & "\" & myResultBook
        MsgBox ThisWorkbook.Path & "\" & myResultBook & vbCrLf & "に結果を保存しました。"
    End If
    
    Application.ScreenUpdating = True
    Unload UserForm1
    
    objIE.Quit  '.Quitで閉じる
    
    Set BookS = Nothing
    Set objTable = Nothing
    Set objIE = Nothing '使用したオブジェクト変数もキレイにしてね。
    Set APL = Nothing
    Workbooks.Open ThisWorkbook.Path & "\" & myResultBook
    ThisWorkbook.Close savechanges:=False
    
Exit Sub

ErrgetTMC:

    MsgBox Err.Number & vbCrLf & Err.Description
    Resume
    GoTo ExitgetTMC
End Sub

サブコード、IE読み込み待ち


Sub WaitIEComp(ByRef objIE As InternetExplorer)

    'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend
End Sub

サブコード、テーブル名取得

Private Function GetTableSummary(objTable As Object, TableNum As Long) As String

On Error GoTo ErrGTS

    Sleep 300
    GetTableSummary = objTable(TableNum).Summary

Exit Function

ErrGTS:

    GetTableSummary = ""
    Err.Clear

End Function

サブコード、時給と交通費取得

Function GetCarfareAndPayment(ByRef objIE As InternetExplorer) As Variant

    Dim n As Long
    Dim n2 As Long
    Dim n3 As Long
    
    n = 0
    n2 = 1 '各個人名のセルは1列目で固定
    
    Dim myTable As Object
    Dim myAddress As String
    Dim myResult As Variant
    ReDim myResult(3, 1) '0名前1アドレス
    
    UserForm1.Label1.Caption = "スタッフの一覧を取得しています。"
    
    objIE.Navigate "https://timecard1.smaregi.jp/staffs/"
    Call WaitIEComp(objIE)
    
    Set myTable = objIE.Document.all.tags("TABLE")
    

    
    '指定されたスタッフの情報ページアドレスを取得
    Do
        If GetTableSummary(myTable, n) = "基本情報" Then
            For n3 = 1 To myTable(n).Rows.Length - 1 '行数分ループ
                If n3 > 1 Then ReDim Preserve myResult(3, UBound(myResult, 2) + 1)
                
                myAddress = myTable(n).Rows(n3).Cells(2).outerHTML
                myAddress = Right(myAddress, Len(myAddress) - 27)
                myAddress = Left(myAddress, Len(myAddress) - 9)
                
                myResult(0, UBound(myResult, 2)) = Right(myAddress, Len(myAddress) - InStr(1, myAddress, ">"))
                myResult(1, UBound(myResult, 2)) = Left(myAddress, InStr(1, myAddress, ">") - 2)
            Next
        End If

        n = n + 1
    Loop Until GetTableSummary(myTable, n) = ""
    
    '取得したページに飛んで時給と交通費を取得
    
    objIE.Visible = True


    n = 0
    

    
    For n = 1 To UBound(myResult, 2)
    
        UserForm1.Label1.Caption = myResult(0, n) & "さんの時給と交通費を取得しています。"
    
        objIE.Navigate "https://timecard1.smaregi.jp/" & myResult(1, n)
        Call WaitIEComp(objIE)
        Set myTable = Nothing
        Set myTable = objIE.Document.all.tags("TABLE")
        
        n2 = myTable.Length - 1
        
        Do
            If GetTableSummary(myTable, n2) = "基本情報" Then
                'MsgBox myTable(n2).Rows(9).Cells(1).innerHTML
                myResult(2, n) = GetCurrencyFromCell(myTable(n2).Rows(7).Cells(1).innerHTML)
                myResult(3, n) = GetCurrencyFromCell(myTable(n2).Rows(9).Cells(1).innerHTML)
                Exit Do
            End If

            n2 = n2 - 1
        Loop Until n2 = 0
    Next n
    
    Set myTable = Nothing
    
    GetCarfareAndPayment = myResult
    

End Function

サブコード、取得した時給情報を数値に変換

Private Function GetCurrencyFromCell(ByVal SourceData As String) As String
    
    Do
        SourceData = Left(SourceData, Len(SourceData) - 1)
        
        If IsNumeric(SourceData) = True Then
            GetCurrencyFromCell = SourceData
            Exit Do
        ElseIf Len(SourceData) = 1 Then
            GetCurrencyFromCell = "0"
            Exit Do
        End If
        
            
    Loop
End Function

サブコード、労働時間を計算しやすいよう数値に変換

Private Function GetPaymentPer(ByVal Times As String, ByVal Payment As String) As Long

    Dim myMinute As String
    Dim myPay As Long
    
    myMinute = Right(Times, 3)
    
    myPay = CLng(Payment) * CLng(Replace(Times, myMinute, ""))
    

    If myMinute = ":30" Then
        myPay = myPay + Payment * 0.5
    End If
    
    GetPaymentPer = myPay

End Function

サブコード、目的の月を呼び出すURLの元になる数値を計算

Private Function GetQueryMonth(ByVal NeedYear As String, ByVal NeedMonth As String) As String

    Dim TodayYear As String
    Dim TodayMonth As String
    Dim DistanceYears As Long
    Dim StartMonth As String
    
    TodayYear = Application.WorksheetFunction.Text(Date, "yyyy")
    TodayMonth = Application.WorksheetFunction.Text(Date, "mm")
    
    If NeedYear < TodayYear Then
        DistanceYears = CLng(TodayYear) - CLng(NeedYear)
        TodayYear = NeedYear
        TodayMonth = CStr(CLng(TodayMonth) + DistanceYears * 12)
        StartMonth = TodayYear & TodayMonth
    Else
        StartMonth = TodayYear & TodayMonth
    End If
    
    GetQueryMonth = CStr(CLng(NeedYear & NeedMonth) - CLng(StartMonth))
    

End Function

サブコード、スマレジから取り込んだ表を計算・出力できる様式に整形する。

Private Sub PreConvList20151201(ByRef SheetResult As Worksheet)

    Dim RngA As Range
    Dim myAr
    Dim myStr As String

    With SheetResult
    
        For Each RngA In SheetResult.UsedRange
            If RngA.Value Like "result*" Then
                If Len(RngA.Value) > 18 Then
                    myStr = RngA.Value
                    myStr = Replace(myStr, vbCrLf, "")
                    RngA.Value = myStr
                    'MsgBox Len(RngA.Value)
                    'RngA.Replace vbCrLf, "", xlPart
                ElseIf Len(RngA.Value) = 18 Then
                    RngA.ClearContents
                End If
            End If
            
            If RngA.Value Like "result*" Then
                myAr = Split(RngA.Value, " ")
                RngA.ClearContents
                RngA.Value = "  " & myAr(2) & " " & myAr(3) & " " & myAr(4) & " " & myAr(5) & " " & myAr(6)
                Erase myAr
            End If
            
            
        Next RngA
    
    End With

End Sub

サブコードでもsleepを使っていますので、メインコード・サブコードをひとつのモジュール内に記述する方が良いと思います。

お問い合わせはこちらから

お名前 (必須)
メールアドレス (必須)
電話番号
住所
お問い合わせ内容 (必須)

確認画面は表示されません。上記内容にて送信しますがよろしいですか?
※ご入力のメールアドレスに自動返信メールが届きます。届かない場合はご入力内容が誤っているか、迷惑メールフォルダに振り分けられた可能性がございますのでご確認お願いいたします。※(必須)
はい