| |
3行ずつ読み飛ばし､4行目をのみ出力する例です
Testして居ないので上手く行かなかったらゴメン
Option Explicit
' アクティブなウィンドウのハンドルを取得する関数の宣言
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Public Sub CSVRead()
' CSVデータの読み込み
Const ForReading = 1
Dim i As Long
Dim lngCount 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 = GetFolderPath
If strPath = "" Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'指定フォルダからファイル名を取得
If Not GetFilesList(vntFileNames, strPath, objFso, ".*", "csv") Then
strProm = "ファイルが有りません"
GoTo Wayout
End If
Application.ScreenUpdating = False
For i = 1 To UBound(vntFileNames)
'カウントの初期値設定
lngCount = 1
'指定ファイルを読み込みモードでOpen
Set objFileStr = objFso.OpenTextFile(vntFileNames(i), ForReading)
With objFileStr
Do Until .AtEndOfStream
'ファイルから１行読み込み
strBuff = .ReadLine
'４行目だけ出力
If lngCount Mod 4 = 0 Then
If strBuff <> "" Then
'CSVをフィールドに分割
vntField = Split(strBuff, ",")
'指定シートの指定行列位置について
With rngWrite.Offset(lngRow)
'フィールドの書き込み
.Resize(, UBound(vntField) + 1).Value = vntField
End With
'書き込み行位置を更新
lngRow = lngRow + 1
End If
End If
'カウントをインクリメント
lngCount = lngCount + 1
Loop
'ファイルをClose
.Close
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 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
vntFileNames = vntRead
GetFilesList = True
End If
Wayout:
'フォルダオブジェクトを破棄
Set objFiles = Nothing
Set objFile = Nothing
End Function
Private Function GetFolderPath() As String
Dim strTitle As String
Dim objFolder As Object
Dim hwnd As Long
Dim strTmpPath As String
Const BIF_RETURNONLYFSDIRS = &H1
Const ssfDESKTOP = &H0
Const CSIDL_WINDOWS = &H24
'アクティブなWindowのハンドルを取得
hwnd = GetForegroundWindow
' 表示タイトルを指定
strTitle = "フォルダを選択して下さい"
' フォルダ選択ダイアログを表示
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(hwnd, strTitle, _
BIF_RETURNONLYFSDIRS, CSIDL_WINDOWS)
' フォルダを選択したときは
If Not (objFolder Is Nothing) Then
' 選択フォルダを表示
With objFolder
' 親フォルダが存在するときは
If Not (.ParentFolder Is Nothing) Then
' 選択フォルダのフルパスを表示
strTmpPath = .Items.Item.Path
' 親フォルダのときは
Else
' フォルダ名を表示
strTmpPath = .Title
End If
End With
' Folderオブジェクトを破棄
Set objFolder = Nothing
End If
If strTmpPath <> "" And Right(strTmpPath, 1) <> "\" Then
strTmpPath = strTmpPath & "\"
End If
GetFolderPath = strTmpPath
End Function
|
|
Hirofumi
- 06/2/2(木) 22:50 -
