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

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

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

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

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

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

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

メインのコードは以下

[vb]
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

[/vb]

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

[vb]

Sub WaitIEComp(ByRef objIE As InternetExplorer)

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

[/vb]

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

[vb]
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
[/vb]

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

[vb]
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
[/vb]

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

[vb]
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
[/vb]

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

[vb]
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
[/vb]

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

[vb]
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
[/vb]

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

[vb]
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
[/vb]

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

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

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

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