| |
続きです。
Private Function GetAppendFile(vntFileNames As Variant, _
strFilePath As String, _
strExtePattan As String, _
strNamePattan As String, _
wksFiles As Worksheet) As Boolean
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim dicIndex As Object
Dim rngList As Range
Dim vntData As Variant
Dim vntAppend() As Variant
Dim vntRead As Variant
Set rngList = wksFiles.Cells(2, "A")
'読み込むファイル名を取得
If Not GetFilesList(vntRead, strFilePath, _
strExtePattan, strNamePattan) Then
GoTo Wayout
End If
With rngList
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
If lngRows < 1 Then
lngRows = 0
Else
If lngRows = 1 Then
ReDim vntData(1 To lngRows, 1 To 2)
vntData(lngRows, 1) = .Resize(lngRows).Value
Else
vntData = .Resize(lngRows).Value
ReDim Preserve vntData(1 To lngRows, 1 To 2)
End If
End If
End With
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
For i = 1 To lngRows
.Add vntData(i, 1), i
Next i
j = 0
For i = 1 To UBound(vntRead)
If .Exists(vntRead(i)) Then
vntData(.Item(vntRead(i)), 2) = "*"
Else
j = j + 1
ReDim Preserve vntAppend(1 To j)
vntAppend(j) = vntRead(i)
End If
Next i
End With
Set dicIndex = Nothing
If j > 0 Then
vntFileNames = vntAppend
GetAppendFile = True
End If
'データ全てに就いて繰り返し
j = 0
For i = 1 To lngRows
'もし、対象データが""で無いなら
If vntData(i, 2) <> "" Then
'書き込み位置を更新
j = j + 1
'配列の対象位置のデータを書き込み位置に代入
vntData(j, 1) = vntData(i, 1)
vntData(j, 2) = vntData(i, 2)
End If
Next i
With rngList
If lngRows > 0 Then
.Resize(lngRows, 2).ClearContents
End If
If j > 0 Then
.Resize(j, 2).Value = vntData
End If
If VarType(vntFileNames) = vbArray + vbVariant Then
.Offset(j).Resize(UBound(vntFileNames)).Value _
= Application.Transpose(vntFileNames)
End If
End With
Wayout:
Set rngList = Nothing
End Function
Private Function GetFilesList(vntFileNames As Variant, _
strFilePath As String, _
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
Dim objFso As Object
'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 = .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) _
= StrConv(strFilePath & "\" & vntRead(i), vbNarrow)
Next i
GetFilesList = True
End If
Wayout:
'フォルダオブジェクトを破棄
Set objFiles = Nothing
Set objFile = Nothing
Set objFso = Nothing
End Function
|
|
ミツコ
- 05/12/11(日) 11:28 -
