EXCELでのTips集計【sample】
永芳
Tipsの集計を毎回EXCELのピボットテーブルで行うのも面倒なため、
VBAでの処理サンプルを作ってみました。
＃ひとまず、
Windows10／EXCEL 2010でザッとは確認しましたが、
しっかりと検証してはいません。。。
（洗練されてもいないのでsampleです）
ただそれだけなんです。。。
操作の流れ：
1. EXECLファイルの準備
※1回準備すればO.K.
（1/28 14:08追記）
書き忘れましたが、
用意したEXCELファイルにSheet2が必要です。
（画像では非表示にしています(^^;）
（2019/01/29 17:37 追記）
※改訂版①は、
実行に際し、参照設定の追加が必要になります。
•Microsoft HTML Object Library
•Microsoft Internet Controls
①ブックオープン時の初期処理を記述する
②標準モジュールに各種マクロを用意する
－変数（グローバル）
－Subプロシージャ
－Functionプロシージャ
を記述
2. 集計の実行
①用意したEXCELファイルを開く
②マイネ王のマイページ（Webブラウザ）で、
パケットの履歴／チップ履歴から
データ（項目行を含め表を丸ごと）をコピーする
③「②」でコピーした表を
「①」で開いたファイルのA1セルに文字で貼り付ける
④マクロ｛Main()｝を実行
（2019/01/29 17:37 追記）
※改訂版①では、
「②」「③」の事前のデータ貼り付けが不要になります。
Private Sub Workbook_Open()
' 過去の入力値（A～D列）クリア
Worksheets("Sheet1").Range("A:D").ClearContents
' 過去の計算値（開始／終了日時）クリア
Worksheets("Sheet2").Cells.ClearContents
Worksheets("Sheet1").Range("F4").ClearContents
Worksheets("Sheet1").Range("F5").ClearContents
' 過去の集計データを削除
Worksheets("Sheet1").Range("E:J").ClearContents
Worksheets("Sheet1").Range("A1").Select
End Sub
' FLAG
' 0:通常の期間抽出
' 1:貼り付け部分（A～D列）の全行を処理する
Public FLAG
Function IsDateEx(s)
Dim i
Dim sDate
Dim sTemp
sDate = ""
'// 数字のみを抽出
For i = 0 To Len(s)
sTemp = Mid(s, i + 1, 1)
'// 数字の場合
If IsNumeric(sTemp) = True Then
sDate = sDate & sTemp
End If
Next
'// 数字8文字でない場合は不正とみなす
If Len(sDate) <> 8 Then
IsDateEx = False
Exit Function
End If
'// 日付形式に変換
sDate = Format(sDate, "####/##/##")
'// 日付チェック
IsDateEx = IsDate(sDate)
End Function
Function IsTime(ByVal strIndata As String, _
Optional strFmt As String = "hh:mm") As Boolean
IsTime = (Format(strIndata, strFmt) = strIndata) * IsDate(strIndata)
End Function
Sub Main()
RC = 0
' 開始／終了日時入力
RC = InputStartDay
If RC <> 0 Then Exit Sub
If FLAG <> 1 Then
RC = InputEndDay
If RC <> 0 Then Exit Sub
End If
' E列に対象フラグ書き込み
Call CreateJudgmentColumn
Application.ScreenUpdating = False
' G列にメンバ抽出
Call MemberListExtraction
' H～J列に集計表を作成
Call CreateTable
' F列に開始／終了日時を表示
Worksheets("Sheet1").Cells(4, 6).Value = "開始日時：" & Worksheets("Sheet2").Cells(2, 1).Value
Worksheets("Sheet1").Cells(5, 6).Value = "終了日時：" & Worksheets("Sheet2").Cells(2, 2).Value
' 集計表を作並べ替え
Call SortTable
Application.ScreenUpdating = True
End Sub
Function InputStartDay()
' 時刻入力
Dim dtm As String
dtm = Application.InputBox( _
Prompt:="開始時刻を入力してください。", _
Default:=Format(Now, "yyyy/mm/dd hh:nn") & " or ALL", _
Type:=2)
If dtm = "ALL" Then
FLAG = 1
Else
FLAG = 0
myDate = Split(dtm, " ")
If IsDateEx(myDate(0)) Then
If IsTime(myDate(1)) Then
Worksheets("Sheet2").Cells(1, 1).Value = "開始日時"
Worksheets("Sheet2").Cells(2, 1).Value = Format(myDate(0) & " " & myDate(1), "yyyy/mm/dd hh:nn")
Else
InputStartDay = 1
MsgBox "無効な時刻 " & myDate(1) & " が入力されました。"
Exit Function
End If
Else
InputStartDay = 1
MsgBox "無効な日付 " & myDate(0) & " が入力されました。"
Exit Function
End If
End If
InputStartDay = 0
End Function
Function InputEndDay()
' 時刻入力
Dim dtm As String
dtm = Application.InputBox( _
Prompt:="終了時刻を入力してください。", _
Default:=Format(Now, "yyyy/mm/dd hh:nn"), _
Type:=2)
myDate = Split(dtm, " ")
If IsDateEx(myDate(0)) Then
If IsTime(myDate(1)) Then
Worksheets("Sheet2").Cells(1, 2).Value = "終了日時"
Worksheets("Sheet2").Cells(2, 2).Value = Format(dtm, "yyyy/mm/dd hh:nn")
Else
InputEndDay = 1
MsgBox "無効な時刻 " & myDate(1) & " が入力されました。"
Exit Function
End If
Else
InputEndDay = 1
MsgBox "無効な日付 " & myDate(0) & " が入力されました。"
Exit Function
End If
InputEndDay = 0
End Function
Sub CreateJudgmentColumn()
' E列に集計対象期間（日時）のフラグを作成する
' 対象 ：1
' 対象外：0
' A列の最終行を求める
MaxRow = Worksheets("Sheet1").Range("A1").End(xlDown).Row
' FLAG=1
If FLAG <> 0 Then
Worksheets("Sheet2").Cells(1, 1).Value = "開始日時"
Worksheets("Sheet2").Range("A2").Value = Worksheets("Sheet1").Cells(MaxRow, 1).Value ' Start
Worksheets("Sheet2").Cells(1, 2).Value = "終了日時"
Worksheets("Sheet2").Range("B2").Value = Worksheets("Sheet1").Cells(2, 1).Value ' End
End If
' フラグ列のRangeを定義
MyRange = "E2:E" & MaxRow
' E列のヘッダ書き込み
Worksheets("Sheet1").Range("E1").Value = "対象"
' E列の数式書き込み
' Worksheets("Sheet1").Range("E2").Select
Worksheets("Sheet1").Range("E2").Activate
If FLAG <> 1 Then
ActiveCell.FormulaR1C1 = _
"=IF(AND(DATEVALUE(RC[-4])+TIMEVALUE(RC[-4])>=DATEVALUE(Sheet2!R2C1)+TIMEVALUE(Sheet2!R2C1),DATEVALUE(RC[-4])+TIMEVALUE(RC[-4])<=DATEVALUE(Sheet2!R2C2)+TIMEVALUE(Sheet2!R2C2)),1,0)"
' E列全体に数式をコピー
Worksheets("Sheet1").Range("E2").Select
Selection.Copy
Worksheets("Sheet1").Range(MyRange).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Else
Worksheets("Sheet1").Range(MyRange).Select
Selection.FormulaR1C1 = "1"
End If
' 再計算
ActiveSheet.Calculate
End Sub
Sub MemberListExtraction()
' G列にメンバを抽出
MaxRow = Worksheets("Sheet1").Range("A1").End(xlDown).Row
MyRange = "D1:D" & MaxRow
Worksheets("Sheet1").Range(MyRange).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Columns("D:D"), CopyToRange:=Range("G1"), Unique:=True
End Sub
Sub CreateTable()
' 集計表を作成する
' G列（抽出したメンバ一覧）の最終行を求める
MaxRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").Cells(Rows.Count, 7).Row, 7).End(xlUp).Row
' 集計表（H[8],I[9],J列[10]）に数式を書き込むRangeを定義
MyRange = "H2:J" & MaxRow
' 集計表（H[8],I[9],J列[10]）ヘッダ書き込み
Worksheets("Sheet1").Range("H1").Select
ActiveCell.FormulaR1C1 = "贈ったチップ"
Worksheets("Sheet1").Range("I1").Select
ActiveCell.FormulaR1C1 = "貰ったチップ"
Worksheets("Sheet1").Range("J1").Select
ActiveCell.FormulaR1C1 = "差分"
' 集計表（H[8],I[9],J列[10]）数式書き込み
Worksheets("Sheet1").Range("H2").Select
ActiveCell.FormulaR1C1 = "=COUNTIFS(C[-3],1,Criteria,RC[-1],C[-6],""10MB"")"
Worksheets("Sheet1").Range("I2").Select
ActiveCell.FormulaR1C1 = "=COUNTIFS(C[-4],1,Criteria,RC[-2],C[-6],""10MB"")"
Worksheets("Sheet1").Range("J2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
Worksheets("Sheet1").Range("H2:J2").Select
If MaxRow > 2 Then Selection.AutoFill Destination:=Range(MyRange)
Worksheets("Sheet1").Range(MyRange).Select
' 空白行（授受無し）を削除
For i = MaxRow To 2 Step -1
If Worksheets("Sheet1").Cells(i, 8).Value = 0 And Worksheets("Sheet1").Cells(i, 9).Value = 0 Then
Worksheets("Sheet1").Range("G" & i & ":J" & i).Select
Selection.Delete Shift:=xlUp
End If
Next i
' 再計算
ActiveSheet.Calculate
End Sub
Sub SortTable()
' 集計表を並べ替える
' G列（集計表）の最終行を求める
MaxRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").Cells(Rows.Count, 7).Row, 7).End(xlUp).Row
' 集計表Rangeを定義
MyRange = "G1:J" & MaxRow
' フィールドを初期化
Worksheets("Sheet1").Range(MyRange).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
' フィールド範囲定義
Dim tmpRange(4) As String
tmpRange(1) = "J2:J" & MaxRow ' ①差分
tmpRange(2) = "H2:H" & MaxRow ' ②贈ったチップ
tmpRange(3) = "I2:I" & MaxRow ' ③貰ったチップ
tmpRange(4) = "G2:G" & MaxRow ' ④お相手
' 並べ替えルール定義
For i = 1 To 4
If i <> 4 Then
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(tmpRange(i)) _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
Else
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(tmpRange(i)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End If
Next i
' 並べ替え実行
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range(MyRange)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' 集計表に列合計を加える
SumRow = MaxRow + 1
Range("G" & SumRow).Select
ActiveCell.FormulaR1C1 = "【合計】"
Range("H" & SumRow).Select
Worksheets("Sheet1").Range("H" & SumRow) = "=SUM(H2:H" & MaxRow & ")"
Range("H" & SumRow).Select
Selection.AutoFill Destination:=Range("H" & SumRow & ":J" & SumRow), Type:=xlFillValues
Range("H" & SumRow & ":J" & SumRow).Select
' 合計行の書式設定
Range("G" & SumRow & ":J" & SumRow).Select
Selection.Font.Bold = True
Range("G" & SumRow).Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
' G列の幅を調整
Columns("G:G").Select
Selection.ColumnWidth = 200
Columns("G:G").EntireColumn.AutoFit
Cells.Select
Cells.EntireRow.AutoFit
Worksheets("Sheet1").Range("G1").Select
End Sub
＜改訂版①－1＞
’’’ IEでデータを自動的に取得する処理を手前に追加
’’’ （事前のデータ貼り付け不要）
Sub Main()
''' Tipsデータの取り込み
Application.ScreenUpdating = False
' IE起動
Dim objIE As InternetExplorer 'IEオブジェクトを準備
Set objIE = CreateObject("Internetexplorer.Application") '新しいIEオブジェクトを作成してセット
objIE.Visible = False 'IEを非表示
Dim strUrl As String '次ページのURL
strUrl = "https://king.mineo.jp/my/＜ご自身のマイページ＞/tips/"
objIE.navigate strUrl 'IEでURLを開く
Do While objIE.Busy = True Or objIE.readyState < READYSTATE_COMPLETE '読み込み待ち
DoEvents
Loop
' HTML取り込み
Dim htmlDoc As HTMLDocument 'HTMLドキュメントオブジェクトを準備
Set htmlDoc = objIE.document 'objIEで読み込まれているHTMLドキュメントをセット
' マイネ王ログイン
On Error Resume Next 'ログイン済みの場合にSkip
htmlDoc.getElementById("session_login").Value = "＜ご自身のマイネ王アカウント＞" 'ユーザー名を入力
htmlDoc.getElementById("session_password").Value = "＜ご自身のパスワード＞" 'パスワードを入力
htmlDoc.getElementById("new_session").submit 'フォームの内容を送信
' セルに<td>タグのtextを代入
With htmlDoc
For i = 0 To .all(1).getElementsByTagName("th").Length - 1
Worksheets("Sheet1").Cells(1, i + 1).Value = .all(1).getElementsByTagName("th")(i).innerHTML
Next i
For i = 0 To .all(1).getElementsByTagName("td").Length - 1
Worksheets("Sheet1").Cells(3 + Int((i - 4) / 4), 1 + Int((i * 4) / 4) Mod 4).Value = .all(1).getElementsByTagName("td")(i).innerHTML
' タグ削除
Worksheets("Sheet1").Cells(3 + Int((i - 4) / 4), 1 + Int((i * 4) / 4) Mod 4).Select
With CreateObject("vbscript.regexp")
.Pattern = "\<.*?\>"
.Global = True
For Each xCell In Selection
xCell.Value = .Replace(xCell.Value, "")
Next
End With
Next i
End With
objIE.Quit
Set objIE = Nothing
' A列の最終行を求める
MaxRow = Worksheets("Sheet1").Range("A1").End(xlDown).Row
' 改行削除
Worksheets("Sheet1").Range("A1:D" & MaxRow).Replace _
What:=vbLf, _
Replacement:="", _
LookAt:=xlPart
' 空白文字削除
Worksheets("Sheet1").Range("A1:D" & MaxRow).Select
Selection.Replace _
What:=" ", _
Replacement:="", _
LookAt:=xlPart
' 退会者対策
Range("D1:D" & MaxRow).Select
Selection.Replace What:="", Replacement:=" （退会済みメンバー）", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
' セルの書式修正
Worksheets("Sheet1").Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormatLocal = "yyyy/mm/dd hh:mm"
Worksheets("Sheet1").Range("A1").Select
Application.ScreenUpdating = True
''' 集計
RC = 0
' 開始／終了日時入力
RC = InputStartDay
If RC <> 0 Then Exit Sub
If FLAG <> 1 Then
RC = InputEndDay
If RC <> 0 Then Exit Sub
End If
' E列に対象フラグ書き込み
Call CreateJudgmentColumn
Application.ScreenUpdating = False
' G列にメンバ抽出
Call MemberListExtraction
' H～J列に集計表を作成
Call CreateTable
' F列に開始／終了日時を表示
Worksheets("Sheet1").Cells(4, 6).Value = "開始日時：" & Worksheets("Sheet2").Cells(2, 1).Value
Worksheets("Sheet1").Cells(5, 6).Value = "終了日時：" & Worksheets("Sheet2").Cells(2, 2).Value
' 集計表を作並べ替え
Call SortTable
Application.ScreenUpdating = True
End Sub
＜改訂版①－2＞
’’’ データCellの書式変更に伴い、判定処理（数式）の変更
Sub CreateJudgmentColumn()
' E列に集計対象期間（日時）のフラグを作成する
' 対象 ：1
' 対象外：0
' A列の最終行を求める
MaxRow = Worksheets("Sheet1").Range("A1").End(xlDown).Row
' FLAG=1
If FLAG <> 0 Then
Worksheets("Sheet2").Cells(1, 1).Value = "開始日時"
Worksheets("Sheet2").Range("A2").Value = Worksheets("Sheet1").Cells(MaxRow, 1).Value ' Start
Worksheets("Sheet2").Cells(1, 2).Value = "終了日時"
Worksheets("Sheet2").Range("B2").Value = Worksheets("Sheet1").Cells(2, 1).Value ' End
End If
' フラグ列のRangeを定義
MyRange = "E2:E" & MaxRow
' E列のヘッダ書き込み
Worksheets("Sheet1").Range("E1").Value = "対象"
' E列の数式書き込み
' Worksheets("Sheet1").Range("E2").Select
Worksheets("Sheet1").Range("E2").Activate
If FLAG <> 1 Then
ActiveCell.FormulaR1C1 = _
"=IF(AND(DATEVALUE(YEAR(RC[-4])&""/""&MONTH(RC[-4])&""/""&DAY(RC[-4]))+TIMEVALUE(HOUR(RC[-4])&"":""&MINUTE(RC[-4]))>=DATEVALUE(Sheet2!R2C1)+TIMEVALUE(Sheet2!R2C1),DATEVALUE(YEAR(RC[-4])&""/""&MONTH(RC[-4])&""/""&DAY(RC[-4]))+TIMEVALUE(HOUR(RC[-4])&"":""&MINUTE(RC[-4]))<=DATEVALUE(Sheet2!R2C2)+TIMEVALUE(Sheet2!R2C2)),1,0)"
' E列全体に数式をコピー
Worksheets("Sheet1").Range("E2").Select
Selection.Copy
Worksheets("Sheet1").Range(MyRange).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Else
Worksheets("Sheet1").Range(MyRange).Select
Selection.FormulaR1C1 = "1"
End If
' 再計算
ActiveSheet.Calculate
End Sub
＜2019/02/12 修正＞
・退会メンバーが含まれていた場合への対応
・集計表に列の合計を追加
エクセルVBAは仕事で少し使ってますが、この集計表は並べ替えや列の幅まで調整してますね💡
明日会社でやってみて、流用して仕事で使います✨
永芳部長ありがとうございました😄
わたしも似たようなものをつくったのですが、VBAでつくる気力と知識がなく、すべて関数で作るしかなかったです。
プリミティヴなCodeでお恥ずかしいsampleですが、何かのお役に立てれば幸いです♪
関数で済むなら関数で済ませたかったのですが、数あるワークシート関数／オプション群の知識（の絶対量）や、それらのCell内／他のCellでの組み合わせ・連携といった高度で複雑な処理は頭がついていかないので、一つ一つ処理を小分けにしてVBAで組むしか出来ません...
コマンドでXPathの書式を用いて対象のTableを取得できたら良かったのですが、そこは出来ず、Webブラウザでの手作業での貼り付けという原始的な手段になってしまいました。。。
googleのサービスはメール、ドライブなど何も使っていないので全然知りませんでしたが。
もしかしてつぎの課題は、
1.一定時間毎に差分を取得。
2.時間を軸にした度数分布グラフに表示。
3.グラフにされた送り主めがけひたすら撃つべし。
最強のレーダーですね。d=(^o^)=b
こういうものを作ってみようとする、モチベーションと目的を与えてくれると言った点では、マイネ王もすてたものではないですね。
取敢えず興味本位（+ちょっとの実用性）で作ってみただけなんです(^^;
ですので、用途は精々【BKGK】大会でチョコチョコ今戦うべき相手を確認するのに使うとか位でしょうかね？
それを考えて開始／終了を指定できるようにしましたが、統計まで行うつもりは正直なところ全然ないのです。。。
定期実行に関しては、
SikuliXでRPAとし、BAT／PowerShell起動（タスクスケジューラ使用）などとしても、コマンドラインのみで処理できる訳ではない為、Session 0が必要になると思いますので動かすためにはWindowsへのローカルログイン状態が必要かも知れないです。（もしUiPath Orchestratorのようにunattended robotと出来るなら別です）
ですから、定期実行は現実的にはどうでしょうかねぇ？！
チップの贈り返しに対しては、
出来たらいいなとは思いました♪
しかしながら、お相手に対してチップを贈る操作は確認ボタンが出てくるので、詳しくは全然知らないのですがSelenium IDE系か、Node.jsと何かの組み合わせ等が必要になる様な気がしていまして、ド素人には出来そうもありません。。。
さすがに全自動で打ち返されたら、相手の方の勝ち目がないですね。
右のモニターに戦況を表示して、それを見ながら 永芳さんが手動で打ち返すぐらいが丁度よく楽しめそうですね。
⇒お相手のセルをHyperLinkにしました。
◆修正①：Main()［抜粋］◆
変更ポイント：タグの削除→HyperLink化
' タグ削除
Worksheets("Sheet1").Cells(3 + Int((i - 4) / 4), 1 + Int((i * 4) / 4) Mod 4).Select
With CreateObject("vbscript.regexp")
.Pattern = "<a.*href=""(.*)"">(.*)<\/.*>"
.Global = True
For Each xCell In Selection
xCell.Value = .Replace(xCell.Value, "=hyperlink(""
Next
End With
変更ポイント：重複削除のみ→HyperLinkセルの利用
Sub MemberListExtraction()
' D列からG列へ「お相手」をコピー
MaxRow = Worksheets("Sheet1").Range("A1").End(xlDown).Row
Worksheets("Sheet1").Range("D1:D" & MaxRow).Select
Selection.Copy
Worksheets("Sheet1").Range("G1").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
' 表示をBold/青に変更
Worksheets("Sheet1").Range("G2:G" & MaxRow).Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
With Selection.Font
.Color = -65536
.TintAndShade = 0
End With
' 重複行を削除
Worksheets("Sheet1").Range("G1:G" & MaxRow).Select
Application.CutCopyMode = False
ActiveSheet.Range("$G$1:$G$" & MaxRow).RemoveDuplicates Columns:=1, Header:=xlYes
Worksheets("Sheet1").Range("G1").Select
End Sub
Main()のURL部分がまた削除されたので、画像で訂正します。
◆修正③：Main()［抜粋］◆変更ポイント：IE操作時のWait方法修正、Logout追加
'完全にページが表示されるまで待機する
Do While objIE.Busy = True Or objIE.readyState <> 4
DoEvents
Loop
'完全にドキュメントが読み込まれるまで待機する
Do Until objIE.document.readyState = "complete"
DoEvents
Loop
' HTML取り込み
' マイネ王ログイン
～～（省略）～～
'完全にページが表示されるまで待機する
Do While objIE.Busy = True Or objIE.readyState <> 4
DoEvents
Loop
'完全にドキュメントが読み込まれるまで待機する
Do Until objIE.document.readyState = "complete"
DoEvents
Loop
' セルに<td>タグのtextを代入
～～（省略）～～
' Wait
Application.Wait Now() + TimeValue("00:00:01")
' Logout
objIE.navigate "https://king.mineo.jp/logout?.done=https://king.mineo.jp/my/＜ご自身のマイページ＞/tips"
' データ有無を確認
If Worksheets("Sheet1").Range("A1").Value = "" Then
MsgBox "データ取得に失敗しました。やり直してください。"
objIE.Quit
Set objIE = Nothing
Exit Sub
End If
Chrome（FireFoxも?!）でログイン済みの状態で表示しているページ内であれば、チップを贈る事が出来る対象は、Javascriptで以下のstatementで絞り込めそうです…
・自分自身は対象外
・連携ナシは対象外
document.querySelectorAll("div.pull-left a[data-method='post']")
⇒絞り込んだelementsを後で取り出せるように配列に入れ直し、その配列の要素それぞれに対し、’forEach’で’.click()’を発行すれば［10MB チップを贈る］ボタンは押せる筈。（実行確認などのボタンが表示されるのは変わりない為、全自動はやはり難しそう）
◆修正④：Main()［抜粋］◆変更ポイント：非表示列の書式設定追加
（データ有無を確認、の手前に以下を挿入）
' B～D列の折り返しを解除
Columns("B:D").Select
Range("D1").Activate
With Selection
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
◆修正⑤：CreateTable()［抜粋］◆変更ポイント：文字列置換の条件を修正
（データ有無を確認、の手前に以下を挿入）
旧：""10MB""
新：""*10MB""
※④、⑤の修正は、
「2/14」特別の”チョコチップ仕様”への対応です(^^;
＃元々、
＃履歴表には10MBとだけ書き込まれていたのが、
＃チョコチップアイコンも加わった為。