| |
改行コードがLfの可能性が有るので
此れで、やって見て、Csvファイルは、マクロの有るBookと同じフォルダに有るとしています
拡張子.csvのファイルを全て抜き出し読み込みます
また、読み込む先は、ActiveSheetのA1からとしています
Option Explicit
Public Sub CSVReadFSO()
' 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 strProm As String
'書き込む位置を設定
Set rngWrite = ActiveSheet.Cells(1, "A")
'FSOのオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
'読み込むファイルのフォルダを設定
strPath = ThisWorkbook.Path
'指定フォルダからファイル名を取得
If Not GetFilesList(vntFileNames, strPath, objFso, "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
If strBuff <> "" Then
'CSVをフィールドに分割
vntField = Split(strBuff, ",")
'指定シートの指定行列位置について
With rngWrite.Offset(lngRow)
'フィールドの書き込み
.Resize(, UBound(vntField) + 1).Value = vntField
End With
'書き込み行位置を更新
lngRow = lngRow + 1
End If
Loop
'ファイルをClose
.Close
End With
Next i
strProm = "処理が完了しました"
Wayout:
Application.ScreenUpdating = True
Set objFileStr = Nothing
Set objFso = Nothing
Set rngWrite = Nothing
Beep
MsgBox strProm
End Sub
Private Function GetFilesList(vntFileNames As Variant, _
strFilePath As String, _
objFso As Object, _
Optional strExtePattan As String = ".*", _
Optional strNamePattan 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
'フォルダの存在確認
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 = .Name
'検索をテスト
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
ReDim vntFileNames(1 To UBound(vntRead))
For i = 1 To UBound(vntRead)
vntFileNames(i) _
= strFilePath & "\" & vntRead(i)
Next i
GetFilesList = True
End If
Wayout:
'フォルダオブジェクトを破棄
Set objFiles = Nothing
Set objFile = Nothing
End Function
|
|
Hirofumi
- 05/8/12(金) 18:22 -
