| |
長すぎるとの事で、読み込み側のコードです
ファイルの読み込みは、以下のコードの値の変更で読み込み位置が変わります
'書き込み先頭行の初期値設定
lngReadRow = 1
'書き込み先頭列の初期値設定
lngReadCol = 1
'書き込むシートの参照を設定
Set wksWrite = ActiveSheet
以下を標準モジュールに記述して下さい
'ファイルの読み込みのコード
Option Explicit
Public Sub ReadCsvSequ()
Dim i As Long
Dim vntFileName As Variant
Dim wksWrite As Worksheet
Dim lngReadRow As Long
Dim lngReadCol As Long
'読み込むファイル名を取得
If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
Exit Sub
End If
'書き込み先頭行の初期値設定
lngReadRow = 1
'書き込み先頭列の初期値設定
lngReadCol = 1
'書き込むシートの参照を設定
Set wksWrite = ActiveSheet
'ファイルを読み込みシートに書き込む
CSVRead vntFileName, wksWrite, lngReadRow, lngReadCol
'書き込むシートの参照を破棄
Set wksWrite = Nothing
Beep
MsgBox "処理が終了しました", vbOKOnly, "終了"
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
ByVal wksWrite As Worksheet, _
Optional ByRef lngRow As Long = 1, _
Optional ByRef lngCol As Long = 1)
Dim dfn As Integer
Dim vntField As Variant
Dim strLine As String
Dim blnMulti As Boolean
Dim strRec As String
'空きファイル番号を取得します
dfn = FreeFile
'ファイルをInputモードでOpen
Open strFileName For Input As dfn
Do Until EOF(dfn)
'１レコード読み込み
Line Input #dfn, strLine
'物理レコードを論理レコードに追加
strRec = strRec & strLine
'レコードをフィールドに分割
vntField = SplitCsv(strRec, ",", , , blnMulti)
If blnMulti Then
strRec = strRec & vbLf
Else
'指定シートに書き込み
With wksWrite.Cells(lngRow, lngCol)
.Offset.Resize(, UBound(vntField) + 1) = vntField
End With
lngRow = lngRow + 1
strRec = ""
End If
Loop
Close #dfn
End Sub
Private Function SplitCsv(ByVal strLine As String, _
Optional strDelimiter As String = ",", _
Optional strQuote As String = """", _
Optional strRet As String = vbCrLf, _
Optional blnMulti As Boolean) As Variant
' strLine :分割元と成る文字列
' strDelimiter :区切り文字
' SplitCsv :戻り値、切り出された文字配列
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim i As Long
Dim vntField As String
Dim lngLength As Long
i = 0
lngStart = 1
lngLength = Len(strLine)
blnMulti = False
Do
ReDim Preserve vntData(i)
If Mid$(strLine, lngStart, 1) <> strQuote Then
lngDPos = InStr(lngStart, strLine, _
strDelimiter, vbBinaryCompare)
If lngDPos > 0 Then
vntField = Mid$(strLine, lngStart, _
lngDPos - lngStart)
lngStart = lngDPos + 1
Else
vntField = Mid$(strLine, lngStart)
lngStart = lngLength + 1
End If
Else
lngStart = lngStart + 1
Do
lngDPos = InStr(lngStart, strLine, _
strQuote, vbBinaryCompare)
If lngDPos > 0 Then
vntField = vntField & Mid$(strLine, _
lngStart, lngDPos - lngStart)
lngStart = lngDPos + 1
Select Case Mid$(strLine, lngStart, 1)
Case ""
Exit Do
Case strDelimiter
lngStart = lngStart + 1
Exit Do
Case strQuote
lngStart = lngStart + 1
vntField = vntField & strQuote
End Select
Else
blnMulti = True
vntField = Mid$(strLine, lngStart) & strRet
lngStart = lngLength + 1
Exit Do
End If
Loop
End If
vntData(i) = vntField
vntField = ""
i = i + 1
Loop Until lngLength <= lngStart
SplitCsv = vntData()
End Function
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean = False) As Boolean
Dim i As Long
Dim strFilter As String
'フィルタ文字列を作成
For i = 1 To 4
strFilter = strFilter & Choose(i, "CSV File (*.csv),*.csv,", _
"Text File (*.txt),*.txt,", _
"CSV and Text (*.csv; *.txt),*.csv;*.txt,", _
"全て (*.*),*.*")
Next i
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames, False
End If
'ファイルを開くダイアログ表示ホルダを表示
vntFileNames _
= Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
Hirofumi
- 03/10/4(土) 20:20 -
