| |
大分前に作った物ですが？
設定した行数分づつ読み込みます
'1回にシート出力する行数(この取り方で多少変化有り)
Const clngRows As Long = 1000
の値で負荷が変わりますので、色々試して下さい
Option Explicit
Public Sub Sample()
'1回にシート出力する行数(この取り方で多少変化有り)
Const clngRows As Long = 1000
Dim i As Long
Dim lngRow As Long
Dim rngResult As Range
Dim strResult() As String
Dim dfn As Integer
Dim vntFileName As Variant
Dim strBuff As String
Dim strProm As String
If Not GetReadFile(vntFileName, ThisWorkbook.Path & "\TestData", False) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'画面更新を停止
Application.ScreenUpdating = False
'出力Listの左上隅セル位置を基準として設定
Set rngResult = ActiveSheet.Cells(1, "A")
dfn = FreeFile
Open vntFileName For Input As dfn
ReDim strResult(1 To clngRows, 1 To 1)
Do Until EOF(dfn)
Line Input #dfn, strBuff
i = i + 1
strResult(i, 1) = strBuff
If i = clngRows Or EOF(dfn) Then
rngResult.Offset(lngRow).Resize(i).Value = strResult
lngRow = lngRow + i
i = 0
ReDim strResult(1 To clngRows, 1 To 1)
End If
Loop
Close #dfn
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngResult = Nothing
MsgBox strProm , vbInformation
End Sub
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean _
= False) As Boolean
Dim strFilter As String
'フィルタ文字列を作成
strFilter = "CSV File (*.csv),*.csv," _
& "Text File (*.txt),*.txt," _
& "Print File (*.prn),*.prn," _
& "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
& "全て (*.*),*.*"
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames & "{TAB}", False
End If
'「ファイルを開く」ダイアログを表示
vntFileNames _
= Application.GetOpenFilename(strFilter, 3, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
