Excel VBA スマレジタイムカードから出勤実績を取得する(その2)
ITサポート恵前回のスマレジタイムカード取得はこちら
さて、スマレジタイムカードですが、9月ごろに仕様が変わりました。
一つはURL、これまでは「http://~~~~/○○○○(年)/○○(月)」だったのですが、これが
「http://~~~~/-1(や-2など)」に変わりました。
どういう意味やねん、ということですが、当月に対して前月なら-1、前々月なら-2、
ということのようです。1,2か月前を見たいならどうってことないですが、何か月も、何年も前、
となるとちょっと考えないといけません。分かりにくくなったと思います。
よって、これまでのコードのままではデータが取得できません。
当月と目的の月の差を計算するサブルーチンが必要となります。
以下、そのサブルーチンです。
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
↑↑↑↑↑↑↑ここまで
このサブルーチンを組み込んだコードが以下になります。
さらに変更点がもう一つ、各表の1行目に月表示が追加されました。
そーんなことか、てなもんですが、プログラムからすると読み込む起点が変わってしまうので、値が正しく取得できません。
こちらは起点を定数で設定し、それに対しての位置を指定することで今回と今後の対応としました。
ちなみに前回複数の表を含むページで二つ目以下の表が読み込めないエラーが発生していましたが、
一旦フルスクリーン表示を挟むことで解決しました（＾.＾）
Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub getTMC() 'IEの表示をテストする。
On Error GoTo ErrgetTMC
If MsgBox("スマレジにログインしている場合はログアウトしてください。", vbOKCancel) = vbCancel Then
Exit Sub
End If
'所定のユーザー名とパスワード
Const myUser As String = "hogehoge@honyarara.com" ←環境にあわせて変えてください。
Const myPass As String = "munyamunya" ←環境にあわせて変えてください。
Const BaseRow As Long = 1
Const ArnStart As Long = 2
Const ArnEnd As Long = 1
'計算用
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 = False
Sleep 100
'処理したいページを表示します。
UserForm1.Label1.Caption = "スマレジタイムカードを読み込み中です。"
objIE.Navigate "https://accounts.smaregi.jp/login?client_id=timecard"
'ページの表示完了を待ちます。
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 1500
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 = 0 To objTable(n).Rows.Length - 1 '列数ループする。
For n3 = 0 To objTable(n).Rows(n2).Cells.Length - 1 '列数分ループ
.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 = "計算後"
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 & ")" _
& "2460)-(" & .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 & ")" _
& "2460)-(" & .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
ThisWorkbook.Close savechanges:=False
Exit Sub
ErrgetTMC:
MsgBox Err.Number & vbCrLf & Err.Description
Resume
GoTo ExitgetTMC
End Sub
↑↑↑↑↑↑↑ここまで
