| |
上手く纏まらないけどこんな物かな？
幾つか条件が有ります
1、（テキストファイル内容）で
この８行のうち、下4行は必ずこの順番で有る事
2、ファイル名の形式は、22030808_160の形式で有る事
拡張子は、「Function GetDataFile」の
「Const strExtend As String = ".txt"」で指定して下さい
簡単に行くかと思ったら意外と面倒、とくにファイルの指定が？
上手く行かなかったらゴメン
Excel97でも動く様にして有りますが、Excel2000以上なら、
Split97の部分をSplit関数に直して下さい
また、Function GetNameもInstrの逆関数が有るので、
其方に直すとコードが簡単に成ると思います
Option Explicit
Public Sub MakeDataSheet()
Dim i As Long
Dim j As Long
Dim k As Long
Dim dfn As Integer
Dim strFileName() As String
Dim strBuff As String
Dim vntResult(0 To 8) As Variant
Dim vntData As Variant
Dim vntItems As Variant
Dim lngWriteRow As Long
'データファイルが無いなら
If Not GetDataFile(strFileName()) Then
Exit Sub
End If
'結果用の列見出しを作成
For i = 0 To 8
vntResult(i) = Choose(i + 1, "ファイル名", "右P1(X)", "右P1(Y)", _
"右P2(X)", "右P2(Y)", "左P1(X)", _
"左P1(Y)", "左P2(X)", "左P2(Y)")
Next i
'ファイルから読み込む行を特定する文字列を設定
vntItems = Array("右P1", "右P2", "左P1", "左P2")
'書き出し行を初期化
lngWriteRow = 1
'Sheet1に書き出す
With Worksheets("Sheet1")
'結果用の列見出しを出力
.Cells(lngWriteRow, 1).Resize(, 9).Value = vntResult
'書き出し行を更新
lngWriteRow = lngWriteRow + 1
'フォルダ上の指定ファイルを繰り返す
For i = 0 To UBound(strFileName, 1)
'ファイルバファ番号を取得
dfn = FreeFile
'ファイルをInputモードでOpen
Open strFileName(i) For Input As dfn
'結果用配列にファイル名を設定
vntResult(0) = GetName(strFileName(i))
'ファイルの終りまで繰り返し
Do Until EOF(dfn)
'ファイルより１行読み込み
Line Input #dfn, strBuff
For j = 0 To 3
'先頭に"右P1", "右P2", "左P1", "左P2"が有る場合
If InStr(1, strBuff, vntItems(j), _
vbBinaryCompare) = 1 Then
'１行をカンマで切り出す
vntData = Split97(strBuff, ",")
'Excel2000以上なら以下の様に変更
' vntData = Split(strBuff, ",")
'2、3番目を結果配列に代入
For k = 1 To 2
vntResult(j * 2 + k) = Trim(vntData(k))
Next k
'"左P2"を読み込んだ時
If j = 3 Then
'結果を出力
.Cells(lngWriteRow, _
1).Resize(, 9).Value = vntResult
'書き出し行を更新
lngWriteRow = lngWriteRow + 1
End If
End If
Next j
Loop
'ファイルを閉じる
Close #dfn
Next i
End With
End Sub
Private Function GetDataFile(strData() As String) As Boolean
Dim i As Long
Dim j As Long
Dim strFilePath As String
Dim strFileName As String
Dim lngTop As Long
Dim lngEnd As Long
Dim lngStep As Long
Dim strProm As String
Dim lngScope(1) As Long
Const strExtend As String = ".txt"
'読み込むファイルの有るフォルダを指定
strFilePath = "C:\Windows\ﾃﾞｽｸﾄｯﾌﾟ\Test"
strFilePath = InputBox("データの有るパスを指定して下さい", _
, strFilePath)
If strFilePath = "" Then
Exit Function
End If
'指定フォルダ上のファイル名を取得
With Application.FileSearch
.NewSearch
.LookIn = strFilePath
.FileName = "????????_???" & strExtend
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) = 0 Then
Beep
MsgBox "検索条件を満たすファイルはありません。"
Exit Function
End If
'ファイルの範囲を指定
For i = 0 To 1
If i = 0 Then
lngTop = 1
lngEnd = .FoundFiles.Count
lngStep = 1
strProm = "開始ファイル"
Else
lngTop = .FoundFiles.Count
lngEnd = 1
lngStep = -1
strProm = "終了ファイル"
End If
Do
strFileName = GetName(.FoundFiles(lngTop))
strFileName = InputBox(strProm & "を指定して下さい" _
& vbCrLf & "パス、拡張子を抜かして", _
, strFileName)
If strFileName = "" Then
Exit Function
End If
strFileName = strFilePath & "\" & strFileName & strExtend
For j = lngTop To lngEnd Step lngStep
If StrComp(strFileName, .FoundFiles(j), _
vbTextCompare) = 0 Then
lngScope(i) = j
Exit For
End If
Next j
If lngScope(i) = 0 Then
Beep
MsgBox "該当するファイルが有りません"
End If
Loop Until lngScope(i) > 0
Next i
If lngScope(0) > lngScope(1) Then
i = lngScope(0)
lngScope(0) = lngScope(1)
lngScope(1) = i
End If
ReDim strData(0 To lngScope(1) - lngScope(0))
For i = lngScope(0) To lngScope(1)
strData(i - lngScope(0)) = .FoundFiles(i)
Next i
End With
GetDataFile = True
End Function
Private Function GetName(ByVal strValue As String) As String
' ファイル名からパス、拡張子の除去
Dim i As Long
Dim lngPos As Long
lngPos = InStr(1, strValue, "\", vbBinaryCompare)
Do Until lngPos = 0
i = lngPos + 1
lngPos = InStr(i, strValue, "\", vbBinaryCompare)
Loop
strValue = Mid(strValue, i)
lngPos = InStr(1, strValue, ".", vbBinaryCompare)
GetName = Left(strValue, lngPos - 1)
End Function
Private Function Split97(ByVal vntLine As Variant, _
Optional ByVal strDeli As String = ",") As Variant
' Excel2000以上の場合必要なし
Dim i As Long
Dim vntData As Variant
Dim lngPos As Long
Dim intDelLen As Integer
intDelLen = Len(strDeli)
i = 0
ReDim vntData(i)
lngPos = InStr(1, vntLine, strDeli, vbBinaryCompare)
Do Until lngPos = 0
vntData(i) = Left(vntLine, lngPos - 1)
vntLine = Mid(vntLine, lngPos + intDelLen)
i = i + 1
ReDim Preserve vntData(i)
lngPos = InStr(1, vntLine, strDeli, vbBinaryCompare)
Loop
vntData(i) = vntLine
Split97 = vntData
End Function
|
|
- 03/8/23(土) 22:43 -
