| |
時間が無いのでTestしていませんが、こんなで読めると思いますが？
Option Explicit
Public Sub CSVRead()
' CSVデータの読み込み
Const ForReading = 1
Dim i As Long
Dim rngWrite As Range
Dim lngRow As Long
Dim strPath As String
Dim vntFileNames As Variant
Dim vntField As Variant
Dim strBuff As String
Dim objFso As Object
Dim objFileStr As Object
Dim blnHeader As Boolean
Dim strBaseName As String
Dim strProm As String
'書き込む位置を設定
Set rngWrite = ActiveSheet.Cells(1, "A")
'FSOのオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
'読み込むファイルのフォルダを設定
strPath = "C:\Documents and Settings\All Users\デスクトップ\CSVフォルダ"
'指定フォルダからファイル名を取得
strBaseName = "^A[0-9][0-9][0-9][0-9][0-9][0-9]$"
If Not GetFilesList(vntFileNames, strPath, objFso, strBaseName, "csv") Then
strProm = "ファイルが有りません"
GoTo Wayout
End If
Application.ScreenUpdating = False
For i = 1 To UBound(vntFileNames)
'指定ファイルを読み込みモードでOpen
Set objFileStr = objFso.OpenTextFile(vntFileNames(i), ForReading)
With objFileStr
Do Until .AtEndOfStream
'ファイルから１行読み込み
strBuff = .ReadLine
'「blnHeader = True」の場合其の行は書きこまない
If Not blnHeader Then
'CSVをフィールドに分割
vntField = SplitCsv(strBuff, ",")
'指定シートの指定行列位置について
With rngWrite.Offset(lngRow)
'フィールドの書き込み
.Resize(, UBound(vntField) + 1).Value = vntField
End With
'書き込み行位置を更新
lngRow = lngRow + 1
End If
'blnHeaderをFaseにして以降の行を書き込む
blnHeader = False
Loop
'ファイルをClose
.Close
'「blnHeader = True」の場合其の行は書きこまない
blnHeader = True
End With
Next i
strProm = "処理が完了しました"
Wayout:
Application.ScreenUpdating = True
Set objFileStr = Nothing
Set objFso = Nothing
Set rngWrite = Nothing
MsgBox strProm, vbInformation
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 Variant
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)
If lngDPos = lngLength Then
ReDim Preserve vntData(i + 1)
End If
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 = Empty
i = i + 1
Loop Until lngLength < lngStart
SplitCsv = vntData()
End Function
Private Function GetFilesList(vntFileNames As Variant, _
strFilePath As String, _
objFso As Object, _
Optional strNamePattan As String = ".*", _
Optional strExtePattan As String = ".*") As Boolean
Dim i As Long
Dim objFiles As Object
Dim objFile As Object
Dim regExten As Object
Dim regName As Object
Dim vntRead() As Variant
Dim strName As String
'FSOのオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
'フォルダの存在確認
If Not objFso.FolderExists(strFilePath) Then
GoTo Wayout
End If
'regExtenpのオブジェクトを取得（正規表現を作成）
Set regExten = CreateObject("VBScript.RegExp")
With regExten
'パターンを設定
.Pattern = strExtePattan
'大文字と小文字を区別しないように設定
.IgnoreCase = True
End With
Set regName = CreateObject("VBScript.RegExp")
With regName
'パターンを設定
.Pattern = strNamePattan
'大文字と小文字を区別しないように設定
.IgnoreCase = True
End With
'フォルダオブジェクトを取得
Set objFiles = objFso.GetFolder(strFilePath).Files
'ファイルの数が0でなければ
If objFiles.Count <> 0 Then
For Each objFile In objFiles
With objFile
strName = .Path
'検索をテスト
If regExten.test(objFso.GetExtensionName(strName)) Then
If regName.test(objFso.GetBaseName(strName)) Then
i = i + 1
ReDim Preserve vntRead(1 To i)
vntRead(i) = strName
End If
End If
End With
Next objFile
End If
Set regExten = Nothing
Set regName = Nothing
If i <> 0 Then
ShellSort vntRead
vntFileNames = vntRead
GetFilesList = True
End If
Wayout:
'フォルダオブジェクトを破棄
Set objFiles = Nothing
Set objFile = Nothing
End Function
Private Sub ShellSort(vntList As Variant)
Dim i As Long
Dim j As Long
Dim lngGap As Long
Dim vntTmp As Variant
Dim lngTop As Long
Dim lngEnd As Long
lngTop = LBound(vntList, 1)
lngEnd = UBound(vntList, 1)
lngGap = 1
Do While lngGap < (lngEnd - lngTop + 1) \ 3
lngGap = 3 * lngGap + 1
Loop
Do Until lngGap <= 0
For i = lngGap + lngTop To lngEnd
vntTmp = vntList(i)
For j = i To lngGap + lngTop Step -lngGap
If vntList(j - lngGap) <= vntTmp Then
Exit For
End If
vntList(j) = vntList(j - lngGap)
Next j
vntList(j) = vntTmp
Next i
lngGap = lngGap \ 3
Loop
End Sub
|
|
Hirofumi
- 06/6/3(土) 10:40 -
