| |
善く解らないけど、こなので善いのかな？
尚、
'読み込むファイルを取得
If Not GetFilesList(vntFileNames, strPath, objFso, _
"xls", "test*") Then
の所で、Folderからファイル名を取得していますが
GetFilesListの第４引数（"xls"）が拡張子を
GetFilesListの第５引数（"test*"） がファイル名を決めています
記述は、正規表現を使用していますので、正規表現の書き方で記述して下さい
以下を標準モジュールに記述して下さい
Option Explicit
Public Sub Posting()
'Copyする列数
Const clngColumns As Long = 1
Dim i As Long
Dim strPath As String
Dim vntFileNames As Variant
Dim wkbMark As Workbook
Dim rngResult As Range
Dim lngRows As Long
Dim lngRow As Long
Dim objFso As Object
Dim strProm As String
'FSOのオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
'パス名定義
' strPath ="C:〜"
strPath = ThisWorkbook.Path & "\TestData"
'読み込み指定されたFolderの確認、変更(必要無ければDo〜Loopまで消して下さい）
Do
strPath = InputBox("読み込むファイルの有るPathを入力して下さい", , strPath)
If strPath = "" Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
Else
If objFso.FolderExists(strPath) Then
Exit Do
Else
Beep
MsgBox strPath & " は存在しません"
End If
End If
Loop
'読み込むファイルを取得
If Not GetFilesList(vntFileNames, strPath, objFso, _
"xls", "test*") Then
strProm = "読み込むファイルが有りません"
GoTo Wayout
End If
'出力する位置を指定
Set rngResult = ActiveWorkbook.Worksheets("Sheet1").Cells(1, "A")
lngRow = 1
Application.ScreenUpdating = False
'Bookデータの読み込み
For i = 1 To UBound(vntFileNames)
'指定BookをOpen
Set wkbMark = Workbooks.Open(vntFileNames(i))
With wkbMark.Worksheets("Sheet1").Cells(1, "A")
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
'データが有る場合
If Not (lngRows <= 1 And .Value = "") Then
'Copyして、指定シートに張り付け
.Resize(lngRows, clngColumns).Copy _
Destination:=rngResult.Offset(lngRow)
'張り付け位置を更新
lngRow = lngRow + lngRows
End If
End With
'指定BookをClose
wkbMark.Close SaveChanges:=False
Next i
strProm = "処理が完了しました"
Wayout:
Application.ScreenUpdating = True
Set objFso = Nothing
Set rngResult = Nothing
Set wkbMark = Nothing
Beep
MsgBox strProm
End Sub
Private Function GetFilesList(vntFileNames As Variant, _
strFilePath As String, _
objFso As Object, _
Optional regExtePattan 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 = regExtePattan
'大文字と小文字を区別しないように設定
.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
ShellSort vntRead
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
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
- 05/8/8(月) 21:08 -
