ブラウザ履歴をエクセルシートに出力するマクロ
2020年02月11日
同じ機能を有するマクロを書いたことがあって、
業務日誌やお気に入り集として活用しているけど、いかんせん重い。
今日は、配列を使って書き直してみた。
なお、ブラウザの履歴を取得する部分は丸パクリです。
cells(j,*)としていたところをArr(j,*)に変えただけ。
最後にArrをシートに転記。cells(*,*).resizeが便利。
要素数は仮で１万件としている。
出力の初期化をせずに毎度１万件の配列を出力するよりは
初期化して、ｊ行まで転記としたほうが２．５倍早かった。
2020/02/12 追記
会社で試してみたら、効果なし。。。
2千行もいかないようなデータをがんばって配列にしたところで
目に見える効果はありませんでした。
業務日誌やお気に入り集として活用しているけど、いかんせん重い。
今日は、配列を使って書き直してみた。
なお、ブラウザの履歴を取得する部分は丸パクリです。
cells(j,*)としていたところをArr(j,*)に変えただけ。
最後にArrをシートに転記。cells(*,*).resizeが便利。
要素数は仮で１万件としている。
出力の初期化をせずに毎度１万件の配列を出力するよりは
初期化して、ｊ行まで転記としたほうが２．５倍早かった。
2020/02/12 追記
会社で試してみたら、効果なし。。。
2千行もいかないようなデータをがんばって配列にしたところで
目に見える効果はありませんでした。
Sub ブラウザ履歴を取得してメッセージ()
Dim tictoc As Double
tictoc = Timer
'Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
Dim WS As Worksheet: Set WS = Worksheets("最近")
Dim kWS As Worksheet: Set kWS = Worksheets("過去")
Dim shell
Dim f, f2, f3
Dim i, i2, i3
Dim j As Long: j = 0
Dim k As Long
Dim Arr(): ReDim Arr(10000, 7)
Dim USERname As String: USERname = ユーザー名取得
Set shell = CreateObject("Shell.Application")
Set f = shell.Namespace("C:\Users\" & ユーザー名取得 & "\AppData\Local\Microsoft\Windows\History")
Dim strAddress As String, strDate As String
For Each i In f.Items
DoEvents
Set f2 = i.GetFolder
For Each i2 In f2.Items
Set f3 = i2.GetFolder
For Each i3 In f3.Items
j = j + 1
strAddress = Replace(f3.getdetailsof(i3, 0), "%20", "") '0:あどれす 1:ﾀｲﾄﾙ 2:最終表示日時
strDate = f3.getdetailsof(i3, 2)
'Arr(j, 0) = i.Name
Arr(j, 1) = i2.Name
Arr(j, 2) = strDate '0:あどれす 1:ﾀｲﾄﾙ 2:最終表示日時
Arr(j, 4) = f3.getdetailsof(i3, 1) '0:あどれす 1:ﾀｲﾄﾙ 2:最終表示日時
Arr(j, 5) = strAddress
Arr(j, 6) = Left(strDate, 10)
'Arr(j, 6) = DayGet日付取得（strDate）
Arr(j, 7) = Right(strDate, 6)
'Arr(j, 7) = TimeGet時刻取得（strDate）
Next
Next
Next
'ﾀｲﾄﾙ作成
Arr(0, 0) = f.getdetailsof("", 0)
Arr(0, 1) = f2.getdetailsof("", 0)
Arr(0, 2) = f3.getdetailsof("", 2) '0:あどれす 1:ﾀｲﾄﾙ 2:最終表示日時
Arr(0, 3) = "link"
Arr(0, 4) = f3.getdetailsof("", 1) '0:あどれす 1:ﾀｲﾄﾙ 2:最終表示日時
Arr(0, 5) = f3.getdetailsof("", 0) '
Arr(0, 6) = "日付"
Arr(0, 7) = "時刻"
Dim target As Range: Set target = WS.Cells(1, 1)
Dim iRowMax: iRowMax = UBound(Arr, 1) - LBound(Arr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(Arr, 2) - LBound(Arr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数
' target.Resize(iRowMax, iColMax).Value = Arr
target.Resize(iRowMax, iColMax).ClearContents
target.Resize(j, iColMax).Value = Arr
Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
End Sub
Private Function ユーザー名取得()
Dim WshNetworkObject As Object
Set WshNetworkObject = CreateObject("WScript.Network")
ユーザー名取得 = WshNetworkObject.USERname
Set WshNetworkObject = Nothing
End Function
PR
Comment