テキストファイルを開くスピード
2020年03月21日
仕事でログの調査をするとき、
ログファイルのサイズが１００MBあったりする。
otabeditで開けないこともないけど、
小さいファイルにまとめようと切り貼りしていると
メモリ不足の警告が出る。めんどくさ。
必要な情報は大したことないので、
欲しい内容をマクロで取り出そうかと。
今回は、本題に入る前にテキストファイルの読み込み速度について、
こんな記事をみつけて早速試してみた。
まぁ当然ですね。配列化も簡単なので今後はこれをメインに使っていこう。
出展元
http://tetsucom.blogspot.com/2011/03/vba_9799.html
でかいテキストファイルがないので、
Dドライブの全ファイル、フォルダを書き出して作った。
コマンドプロンプトから
Dir /S D: > フルネーム.txt
ファイルのフルネームは、当該ファイルをコピーして
ファイル名を指定して実行のウィンドウにペーストすると出てくる。
出力結果は３Mぐらい。ちょっと小さめだけどまあいいか。
ついでにCドライブも試したら、１０MB。
実行結果（１０MB)
１行ずつ読み込むLineInputのほうが圧倒的に早かった。むー。
【3/23追記】
54,618kBのファイルで再試験したところ、バイナリが最速でした。
以下、ソース。
ログファイルのサイズが１００MBあったりする。
otabeditで開けないこともないけど、
小さいファイルにまとめようと切り貼りしていると
メモリ不足の警告が出る。めんどくさ。
必要な情報は大したことないので、
欲しい内容をマクロで取り出そうかと。
今回は、本題に入る前にテキストファイルの読み込み速度について、
こんな記事をみつけて早速試してみた。
VBA テキストファイルの最も高速な読み込み方法
・OpenステートメントのBinaryモードにより一括バイナリ読み込み、Unicode変換が最も高速という結果になりました。まぁ当然ですね。配列化も簡単なので今後はこれをメインに使っていこう。
出展元
http://tetsucom.blogspot.com/2011/03/vba_9799.html
でかいテキストファイルがないので、
Dドライブの全ファイル、フォルダを書き出して作った。
コマンドプロンプトから
Dir /S D: > フルネーム.txt
ファイルのフルネームは、当該ファイルをコピーして
ファイル名を指定して実行のウィンドウにペーストすると出てくる。
出力結果は３Mぐらい。ちょっと小さめだけどまあいいか。
ついでにCドライブも試したら、１０MB。
実行結果（１０MB)
TextFileToBuf :2.0009765625
Line :0.00390625
binary :0.154296875
実行結果（３MB)
実行結果（３MB)
TextFileToBuf :0.716796875
Line :0.0009765625
binary :0.0654296875
記事に書いてあったバイナリよりも１行ずつ読み込むLineInputのほうが圧倒的に早かった。むー。
【3/23追記】
54,618kBのファイルで再試験したところ、バイナリが最速でした。
TextFileToBuf :33.6
Line :645.9
binary :6.2
以下、ソース。
Option Explicit
Sub Main()
'ファイル選択ダイアログでファイルを指定
Dim vFilePath As Variant, buf As String
vFilePath = Application.GetOpenFilename
Dim tictoc As Double
tictoc = Timer
buf = TextFileToBuf(vFilePath)
Debug.Print "TextFileToBuf :" & Timer - tictoc
tictoc = Timer
buf = txtファイル読み込み_LineInput(vFilePath)
Debug.Print "Line :" & Timer - tictoc
tictoc = Timer
buf = txtファイル読み込み_binary(vFilePath)
Debug.Print "binary :" & Timer - tictoc
End Sub
Function ファイル名()
Dim vFilePath As Variant
vFilePath = Application.GetOpenFilename
ファイル名 = vFilePath
End Function
Function TextFileToBuf(FullName) As String
Dim buf As String
With CreateObject("Scripting.FileSystemObject")
With .GetFile(FullName).OpenAsTextStream
buf = .ReadAll
.Close
End With
End With
TextFileToBuf = buf
End Function
Function txtファイル読み込み_binary(vFilePath)
If vFilePath = False Then
txtファイル読み込み_binary = ""
End If
'ファイルサイズが０バイトの場合も処理終了
Dim nFileLen As Long
nFileLen = FileLen(vFilePath)
If nFileLen = 0 Then
txtファイル読み込み_binary = ""
End If
'指定されたファイルを取得したファイル番号としてバイナリモードで開く
Open vFilePath For Binary As #1
'ファイルサイズ分のバイト配列を用意
Dim bData() As Byte
ReDim bData(0 To nFileLen - 1)
'バイト配列に指定ファイルを展開
Get #1, , bData
Close #1
txtファイル読み込み_binary = StrConv(bData(), vbUnicode) 'Unicodeに変換
End Function
Function txtファイル読み込み_LineInput(vFilePath)
If vFilePath = False Then
txtファイル読み込み_LineInput = ""
End If
'ファイルサイズが０バイトの場合も処理終了
Dim nFileLen As Long
nFileLen = FileLen(vFilePath)
If nFileLen = 0 Then
txtファイル読み込み_LineInput = ""
End If
Dim buf As String, TextLine As String
'指定されたファイルを取得したファイル番号としてバイナリモードで開く
Open vFilePath For Input As #1
Line Input #1, TextLine
buf = buf & TextLine
Close #1
txtファイル読み込み_LineInput = buf
End Function
PR
Grep結果をシート出力するマクロ
2020年02月29日
ファイルサイズの大きいテキストデータを扱うときにotbEditを使っている。
otbEdit（オタベエディタ）には、Grep機能があって、
特定の文字列を含む行をフォルダ内のテキストファイルから検索して一覧で出してくれる。
便利なんだけど、出力結果が扱いづらい形式で出てくるので、
エクセルに転記するマクロを作ってみた。
出力形式は以下のとおり。
ファイルフルネーム（行数）：行内容
フルネームからフォルダ名、ファイル名、拡張子に分割して、
№をつけて出力。
クリップボードから読み込みとファイルから読み込みをできるようにした。
以下、ソース。
otbEdit（オタベエディタ）には、Grep機能があって、
特定の文字列を含む行をフォルダ内のテキストファイルから検索して一覧で出してくれる。
便利なんだけど、出力結果が扱いづらい形式で出てくるので、
エクセルに転記するマクロを作ってみた。
出力形式は以下のとおり。
ファイルフルネーム（行数）：行内容
フルネームからフォルダ名、ファイル名、拡張子に分割して、
№をつけて出力。
クリップボードから読み込みとファイルから読み込みをできるようにした。
以下、ソース。
Option Explicit
Sub ◆oGrep結果の取り込み()
Dim RC As Long
RC = MsgBox("取り込み対象テキストの指定。クリップボードから取り込みますか？", vbYesNoCancel)
Dim TextBuf As String
If RC = vbCancel Then
Exit Sub
ElseIf RC = vbYes Then
TextBuf = クリップボードの値を取得 'オートフィルタ Function クリップボードの値を取得() As String
Else 'ファイルから
TextBuf = テキストファイルをバッファへ(txtファイル名取得)
End If
Dim TextArray: TextArray = Split(TextBuf, Chr(10))
Dim TextLine As String, i As Long, cnt As Long: cnt = 1
Dim cPos As Long, LPos As Long, pPos As Long, yPos As Long, yPos2 As Long
Dim Arr(): ReDim Arr(UBound(TextArray), 6)
Arr(0, 0) = "№"
Arr(0, 1) = "FullName"
Arr(0, 2) = "Folder"
Arr(0, 3) = "File"
Arr(0, 4) = "Ext"
Arr(0, 5) = "Line"
Arr(0, 6) = "Text"
For i = 1 To UBound(TextArray) - 1 '１行目は「解析中」なので無視
TextLine = TextArray(i)
If Mid(TextLine, 2, 1) = ":" Then
cPos = InStr(3, TextLine, ":")
LPos = InStrRev(Left(TextLine, cPos), "(")
pPos = InStrRev(Left(TextLine, cPos), ".")
yPos = InStrRev(Left(TextLine, cPos), "\")
yPos2 = InStrRev(Left(TextLine, yPos - 1), "\")
Arr(cnt, 0) = cnt - 0
Arr(cnt, 1) = Left(TextLine, LPos - 1)
Arr(cnt, 2) = Mid(TextLine, yPos2 + 1, yPos - yPos2 - 1)
Arr(cnt, 3) = Mid(TextLine, yPos + 1, LPos - yPos - 1)
Arr(cnt, 4) = Mid(TextLine, pPos + 1, LPos - pPos - 1) '"Ext"
Arr(cnt, 5) = Mid(TextLine, LPos + 1, cPos - LPos - 2) '"Line"
Arr(cnt, 6) = Right(TextLine, Len(TextLine) - cPos) '"Text"
cnt = cnt + 1
End If
Next i
'出力
Worksheets.Add
Call ArrayToCell_2d(Cells(1, 1), Arr)
ActiveSheet.Name = "oGrep"
End Sub
Private Function txtファイル名取得(Optional デフォルト As String = "")
If デフォルト = "" Then
デフォルト = デスクトップパス
End If
Dim i As Long
'’https://excel-ubara.com/excelvba1/EXCELVBA376.html
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FulName As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = デフォルト
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "テキストファイル", "*.txt"
.Filters.Add "すべてのファイル", "*.*"
.Title = "テキストファイルの選択"
If .Show = True Then
FulName = .SelectedItems(1)
Else
MsgBox "キャンセルしました"
End If
End With
Set FSO = Nothing
txtファイル名取得 = FulName
End Function
Function クリップボードの値を取得() As String
'クリップボードから文字列を取得
'https://www.ka-net.org/blog/?p=7537
With CreateObject("Forms.TextBox.1")
.MultiLine = True
If .CanPaste = True Then .Paste
クリップボードの値を取得 = .Text
End With
End Function
Function テキストファイルをバッファへ(FullName As String) As String
Dim buf As String
With CreateObject("Scripting.FileSystemObject")
With .GetFile(FullName).OpenAsTextStream
buf = .ReadAll
.Close
End With
End With
テキストファイルをバッファへ = buf
End Function
Sub ArrayToCell_2d(Target As Range, oArr, Optional ColCnt As Long = 0) '配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数
'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合
If ColCnt > 0 And ColCnt <= iColMax Then
Target.Resize(iRowMax, ColCnt).Value = oArr
Else
Target.Resize(iRowMax, iColMax).Value = oArr
End If
End Sub
Private Function デスクトップパス()
Dim UserName As String
UserName = ユーザー名取得
デスクトップパス = "C:\Users\" & UserName & "\Desktop"
End Function
Private Function ユーザー名取得()
Dim WshNetworkObject As Object
Set WshNetworkObject = CreateObject("WScript.Network")
ユーザー名取得 = WshNetworkObject.UserName
Set WshNetworkObject = Nothing
End Function
コマンドプロンプトでDIRコマンドを実行するマクロ
2020年02月13日
最近CMDのDIRに凝ってます。
普通にマクロ組むより圧倒的に早い。ただ使いづらい。
前回は、DIRコマンドの結果を出力したファイルを取り込んで
解析するマクロを作ったものの、
いちいちファイル指定するの面倒なのでまとめることに。
ひとまず今回は、ファイル出力するまで。
例によって今回もoffice TANAKAさんのHPのお世話になりました。
http://officetanaka.net/excel/vba/tips/tips27.htm
解析したフォルダのひとつしたの階層に本ブックを保存して
モジュールを実行。
パスについては、thisworkbook.pathで指定しているので、
カスタマイズすればOK。
CMDのコマンドについてはモジュール化したので、
引数にコマンドを入れればOK
ダブルコーテーションの中でダブルコーテーションの入力は
２つ重ねることで１文字表示する。すげー見づらい。。。
以下ソース。
普通にマクロ組むより圧倒的に早い。ただ使いづらい。
前回は、DIRコマンドの結果を出力したファイルを取り込んで
解析するマクロを作ったものの、
いちいちファイル指定するの面倒なのでまとめることに。
ひとまず今回は、ファイル出力するまで。
例によって今回もoffice TANAKAさんのHPのお世話になりました。
http://officetanaka.net/excel/vba/tips/tips27.htm
解析したフォルダのひとつしたの階層に本ブックを保存して
モジュールを実行。
パスについては、thisworkbook.pathで指定しているので、
カスタマイズすればOK。
CMDのコマンドについてはモジュール化したので、
引数にコマンドを入れればOK
ダブルコーテーションの中でダブルコーテーションの入力は
２つ重ねることで１文字表示する。すげー見づらい。。。
以下ソース。
Sub 上のフォルダをDIR解析()
'CMD で DIRコマンド
'ターゲットフォルダはひとつ上の階層
'txtファイルはここの階層に出力
'出力したテキストを自動的に取り込み
Dim txtPath As String: txtPath = ThisWorkbook.Path 'ここのフォルダパス
Dim yPos As Long: yPos = InStrRev(txtPath, "\")
Dim tarPath As String: tarPath = Left(txtPath, yPos - 1) '対象フォルダパス
Dim txtFulName As String: txtFulName = txtPath & "\" & "Dirリスト.txt"
Dim sCmd As String
sCmd = "Dir """ & tarPath & """ /S /A-D > """ & txtFulName & """ " 'ファイルとDir 指定できてない
Call ExcuteCommand_cmd(sCmd)
'Stop
End Sub
Private Sub ExcuteCommand_cmd(sCmd As String)
Dim WSH, wExec, Result As String
Set WSH = CreateObject("WScript.Shell") ''(1)WSHへの参照を作ります
Set wExec = WSH.Exec("%ComSpec% /c " & sCmd) ''(3)Execメソッドを実行
Do While wExec.Status = 0 ''(4)ループで完了を待ち
DoEvents
Loop
Set wExec = Nothing
Set WSH = Nothing
End Sub
ファイル一覧解析マクロ（その２）
2020年02月12日
前回作ったマクロの利便性が微妙だったので手直し。
/Bありで解析するパターンは、
FSOを使ってファイルの全行を読み込み、
split関数で配列に格納して1つずつ処理していた。
１行ずつ処理するならlinereadで処理したほうがいいなと思い
手を入れてみたら、IF文の分岐を結合して
ちょっと手直しするくらいでいけた。
If Right(buf, Len("のディレクトリ")) = "のディレクトリ" Then
ElseIf Mid(buf, 5, 1) = "/" And Mid(buf, 8, 1) = "/" Then
ElseIf Mid(buf, 2, 1) = ":" Then 'dirB用に追記
End If
あと、ファイル選択をオプションにすべく、
実行モジュールとメインモジュールに分割。
optional fname as string = ""とした。以下ソース。
/Bありで解析するパターンは、
FSOを使ってファイルの全行を読み込み、
split関数で配列に格納して1つずつ処理していた。
１行ずつ処理するならlinereadで処理したほうがいいなと思い
手を入れてみたら、IF文の分岐を結合して
ちょっと手直しするくらいでいけた。
If Right(buf, Len("のディレクトリ")) = "のディレクトリ" Then
ElseIf Mid(buf, 5, 1) = "/" And Mid(buf, 8, 1) = "/" Then
ElseIf Mid(buf, 2, 1) = ":" Then 'dirB用に追記
End If
あと、ファイル選択をオプションにすべく、
実行モジュールとメインモジュールに分割。
optional fname as string = ""とした。以下ソース。
Option Explicit
Private Sub ストップウォッチ(ByRef tictoc)
If tictoc = 0 Then
tictoc = Timer
Else
Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
tictoc = Timer
End If
End Sub
Sub ■dir結果の解析()
Call dir結果の解析
' Call dir結果の解析("C:\Users\Akihiro\Desktop\sadb.txt")
End Sub
Private Sub dir結果の解析(Optional fPath As String = "")
' dir "D:\Dropbox\VBA" /s /a-d > "D:\Dropbox\VBA\dirout.txt"
If fPath = "" Then fPath = txtファイル名取得("DIR /A-D /Sの解析結果ファイルの選択")
If fPath = "" Then Exit Sub
Dim tictoc As Single
Call ストップウォッチ(tictoc)
Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")
Dim buf As String, Path As String
Dim strDate As String, fSize As String, fname As String, Ext As String
'タイトル行作成
On Error Resume Next
Dic.Add "FulName", "Folder" & "‡" & "File" & "‡" & "Date" & "‡" & "Size" & "‡" & "Ext"
Open fPath For Input As #1
Do Until EOF(1)
Line Input #1, buf
If Right(buf, Len("のディレクトリ")) = "のディレクトリ" Then
Path = Trim(Replace(buf, "のディレクトリ", ""))
ElseIf Mid(buf, 5, 1) = "/" And Mid(buf, 8, 1) = "/" Then
strDate = Replace(Trim(Mid(buf, 1, 17)), " ", " ")
fSize = Trim(Mid(buf, 19, 17))
fname = Trim(Mid(buf, 37, Len(buf) - 37 + 1))
Ext = 拡張子(fname)
Dic.Add Path & "\" & fname, AddressToLink(Path, ファイル名(Path)) & "‡" & fname & "‡" & strDate & "‡" & fSize & "‡" & Ext
ElseIf Mid(buf, 2, 1) = ":" Then 'dirBの場合
fname = ファイル名(buf)
Path = Left(buf, Len(buf) - Len(fname) - 1)
Ext = 拡張子(buf)
strDate = FileDateTime(buf)
fSize = FileLen(buf)
Dic.Add buf, AddressToLink(Path, ファイル名(Path)) & "‡" & fname & "‡" & strDate & "‡" & fSize & "‡" & Ext
strDate = ""
fSize = ""
End If
Loop
Close #1
Dim keys: keys = Dic.keys
Dim Items: Items = Dic.Items
Set Dic = Nothing
Dim Arr(): ReDim Arr(UBound(keys), 5)
Dim oBuf, i As Long, j As Long
For i = 0 To UBound(keys)
oBuf = Split(Items(i), "‡")
For j = 0 To UBound(oBuf)
Arr(i, j) = oBuf(j)
Next j
Next i
'出力
Worksheets.Add
Call ChangeSheetName("dir_" & ファイル名(fPath))
Dim OutPutCell As Range: Set OutPutCell = Cells(1, 1)
Call ArrayToCell_1d_trns(OutPutCell, keys)
Call ArrayToCell_2d(OutPutCell.Offset(0, 1), Arr)
Call オートフィルタと枠固定と罫線(OutPutCell)
Dim OutPutRange As Range: Set OutPutRange = OutPutCell.Resize(UBound(Arr, 1) + 1, 1)
OutPutRange.Offset(1, 3).NumberFormatLocal = "yyyy/mm/dd hh:mm"
OutPutRange.Offset(1, 4).NumberFormatLocal = "#,##0"
Cells(1, "H") = AddressToLink(fPath, "dir > " & fPath)
Call ストップウォッチ(tictoc)
End Sub
Private Sub オートフィルタと枠固定と罫線(OutPutCell As Range)
OutPutCell.Offset(1, 1).Select
ActiveWindow.FreezePanes = True 'ウィンドウ枠の固定ON
OutPutCell.AutoFilter
With ActiveSheet.AutoFilter.Range
.CurrentRegion.Borders.LineStyle = xlContinuous
End With
End Sub
Private Sub ChangeSheetName(shName As String)
Dim flag As Boolean
If UsedSheetName(shName) = False Then
ActiveSheet.Name = shName
Exit Sub
End If
Dim cnt As Long: cnt = 2
Dim NewName As String: NewName = shName & " (" & cnt & ")"
Do While UsedSheetName(NewName) = True
cnt = cnt + 1
NewName = shName & " (" & cnt & ")"
Loop
ActiveSheet.Name = NewName
End Sub
Private Function UsedSheetName(shName As String) As Boolean
Dim ws As Worksheet, flag As Boolean
For Each ws In Worksheets
If ws.Name = shName Then flag = True
Next ws
UsedSheetName = flag
End Function
Private Sub ArrayToCell_1d_trns(Target As Range, oArr) '配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1
Dim iColMax: iColMax = 1 '１列データは転置が必要
Target.Resize(iRowMax, iColMax).Value = WorksheetFunction.Transpose(oArr)
End Sub
Function AddressToLink(Address As String, Caption As String) As String
AddressToLink = "=hyperlink(""" & Address & """,""" & Caption & """)"
End Function
Function Path2Link(Path As String) As String
Path2Link = "=Hyperlink(""" & Path & """,""" & Path & """)"
End Function
Function txtファイル名取得(Optional タイトル As String = "テキストファイルの選択", Optional デフォルト As String = "")
If デフォルト = "" Then
デフォルト = デスクトップパス
End If
Dim i As Long
'’https://excel-ubara.com/excelvba1/EXCELVBA376.html
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FulName As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = デフォルト
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "テキストファイル", "*.txt"
.Filters.Add "すべてのファイル", "*.*"
.Title = タイトル
If .Show = True Then
FulName = .SelectedItems(1)
Else
MsgBox "キャンセルしました"
End If
End With
Set FSO = Nothing
txtファイル名取得 = FulName
End Function
Private Function ユーザー名取得()
Dim WshNetworkObject As Object
Set WshNetworkObject = CreateObject("WScript.Network")
ユーザー名取得 = WshNetworkObject.UserName
Set WshNetworkObject = Nothing
End Function
Private Function デスクトップパス()
Dim UserName As String
UserName = ユーザー名取得
デスクトップパス = "C:\Users\" & UserName & "\Desktop"
End Function
Sub ArrayToCell_2d(Target As Range, oArr, Optional ColCnt As Long = 0) '配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数
'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合
If ColCnt > 0 And ColCnt <= iColMax Then
Target.Resize(iRowMax, ColCnt).Value = oArr
Else
Target.Resize(iRowMax, iColMax).Value = oArr
End If
End Sub
Function 拡張子(FileName As String) As String
Dim pPos As Long
pPos = InStrRev(FileName, ".")
If pPos <> 0 Then
拡張子 = Right(FileName, Len(FileName) - pPos)
Else
拡張子 = ""
End If
End Function
Function ファイル名(FileName As String) As String
Dim yPos As Long
yPos = InStrRev(FileName, "\")
If yPos <> 0 Then
ファイル名 = Right(FileName, Len(FileName) - yPos)
Else
ファイル名 = ""
End If
End Function
Function TextFileToBuf(FullName As String) As String
If FullName = "" Then Exit Function
Dim buf As String
With CreateObject("Scripting.FileSystemObject")
With .GetFile(FullName).OpenAsTextStream
buf = .ReadAll
.Close
End With
End With
TextFileToBuf = buf
End Function
ブラウザ履歴をエクセルシートに出力するマクロ
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