| |
>下記の｢If vntField(4) = "Voiding" Then｣で止まってしまいます。
どの様な、止まり方をしているのが不明なので、善く解りませんが？
多分、データが、５フィールド分無いのでは？
E列に有る「Voiding」をカウントと有るので、
先頭から5番目のフィールド（配列が、0から始まるので）を見ているのですが？
実際にどの様なデータに成って居るのかサンプルをUpして下さい
ここで、見せてはマズイ部分は、「AAA」とかでも善いですから
>現在自宅で走らせていますが、97なのですが関係有りますか？
Excel97で問題は無いと思います
何故なら、此れを書いているのが、Win98、Excel97ですので
>全て通しで提供頂けたらと思います。
Option Explicit
Public Sub ReadRle2()
Dim i As Long
Dim vntFileNames As Variant
Dim lngWrite As Long
Dim blnHeader As Boolean
Dim wkbNewBook As Workbook
Dim wksNewSheet As Worksheet
Dim wksVoiding As Worksheet
Dim vntVoiding As Variant
Dim lngVoidingRow As Long
Dim strPath As String
Dim objFso As Object
'FSOのオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
' Application.ScreenUpdating = False
'新規Bookを追加
Set wkbNewBook = Workbooks.Add
Set wksVoiding = wkbNewBook.Worksheets("Sheet1")
lngVoidingRow = 1
wksVoiding.Cells(lngVoidingRow, "A").Resize(, 4).Value _
= Array("Folder", "FileName", "Voiding", "Voiding累計")
lngVoidingRow = lngVoidingRow + 1
wksVoiding.Name = "Voidingカウント一覧" '★この行追加
'Voidingカウント用の変数を初期化
ReDim vntVoiding(1 To 3)
'ファイルを開くダイアログを表示してファイル名を取得
Do While GetReadFile(vntFileNames, ThisWorkbook.Path, True)
'新規Bookに書き込み用シートを追加
With wkbNewBook.Worksheets
Set wksNewSheet = .Add(After:=.Item(.Count))
End With
strPath = objFso.GetParentFolderName(vntFileNames(1))
wksVoiding.Cells(lngVoidingRow, 1).Value = strPath
vntVoiding(3) = 0 '★この行追加
'書き込み行の初期値
lngWrite = 1
'先頭行を書き込み
blnHeader = True
'取得したファイル名全てに繰り返し
For i = 1 To UBound(vntFileNames)
'Voidingカウント用の変数を初期設定
vntVoiding(1) = objFso.GetBaseName(vntFileNames(i))
vntVoiding(2) = 0
'書き込み用シートに出力
CSVRead vntFileNames(i), objFso, wksNewSheet, _
vntVoiding, lngWrite, 1, blnHeader, ","
'先頭行をスッキプ
'blnHeader = False
'Voidingカウント総数用の変数にVoidingカウントを加算
vntVoiding(3) = vntVoiding(3) + vntVoiding(2)
With wksVoiding
.Cells(lngVoidingRow, 2).Resize(, 3).Value = vntVoiding
lngVoidingRow = lngVoidingRow + 1
End With
Next i
wksNewSheet.Name = NameLetter(strPath)
'ファイル名取得用変数の初期化
vntFileNames = ""
Loop
Set wksNewSheet = Nothing
Set wkbNewBook = Nothing
Set wksVoiding = Nothing
Set objFso = Nothing
' Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
ByVal objFso As Object, _
ByRef wksWrite As Worksheet, _
ByRef vntTotal As Variant, _
Optional ByRef lngRow As Long = 1, _
Optional ByRef lngCol As Long = 1, _
Optional ByRef blnHeader As Boolean = True, _
Optional strDelim As String = ",")
Dim vntField As Variant
Dim strLine As String
Dim blnMulti As Boolean
Dim strRec As String
Dim wkbParent As Workbook
Dim objFileStr As Object
Const ForReading = 1
Set wkbParent = wksWrite.Parent
'指定ファイルを読み込みモードでOpen
Set objFileStr = objFso.OpenTextFile(strFileName, ForReading)
With objFileStr
Do Until .AtEndOfStream
strLine = .ReadLine
strRec = strRec & strLine
vntField = SplitCsv(strRec, strDelim, , , blnMulti)
If blnMulti Then
strRec = strRec & vbLf
Else
If blnHeader Then
If UBound(vntField) >= 4 Then
If vntField(4) = "Voiding" Then
vntTotal(2) = vntTotal(2) + 1
End If
End If
With wksWrite.Cells(lngRow, lngCol)
.Offset.Resize(, UBound(vntField) + 1) = vntField
End With
lngRow = lngRow + 1
If lngRow > 65536 Then
lngRow = 1
With wkbParent.Worksheets
Set wksWrite = .Add(After:=.Item(.Count))
End With
End If
End If
strRec = ""
blnHeader = True
End If
Loop
.Close
End With
Set objFileStr = Nothing
Set wkbParent = Nothing
End Sub
Private Function NameLetter(ByVal strName As String) As String
' シート名のチェック
Dim i As Long
Dim vntLetter As Variant
Dim lngPos As Long
'シート名として使用不可能な文字の一覧を作成
vntLetter = Array(":", "\", "?", "[", "]", "/", "*")
'一覧全てに就いて
For i = 0 To UBound(vntLetter, 1)
'引数の文字列に一覧の文字が含まれるか探索
lngPos = InStr(1, strName, vntLetter(i), vbTextCompare)
'引数の文字列に一覧の文字が無くなるまで繰り返し
Do Until lngPos = 0
'有る場合、"_"に置換
strName = Left(strName, lngPos - 1) _
& "_" & Mid(strName, lngPos + 1)
'引数の文字列に一覧の文字が含まれるか探索
lngPos = InStr(1, strName, vntLetter(i), vbTextCompare)
Loop
Next i
'戻り値として、置換後の文字列を返す
NameLetter = strName
End Function
Private Function SplitCsv(ByVal strLine As String, _
Optional strDelimiter As String = ",", _
Optional strQuote As String = """", _
Optional strRet As String = vbCrLf, _
Optional blnMulti As Boolean) As Variant
' strLine :分割元と成る文字列
' strDelimiter :区切り文字
' SplitCsv :戻り値、切り出された文字配列
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim i As Long
Dim vntField As Variant
Dim lngLength As Long
i = 0
lngStart = 1
lngLength = Len(strLine)
blnMulti = False
Do
ReDim Preserve vntData(i)
If Mid$(strLine, lngStart, 1) <> strQuote Then
lngDPos = InStr(lngStart, strLine, _
strDelimiter, vbBinaryCompare)
If lngDPos > 0 Then
vntField = Mid$(strLine, lngStart, _
lngDPos - lngStart)
lngStart = lngDPos + 1
Else
vntField = Mid$(strLine, lngStart)
lngStart = lngLength + 1
End If
Else
lngStart = lngStart + 1
Do
lngDPos = InStr(lngStart, strLine, _
strQuote, vbBinaryCompare)
If lngDPos > 0 Then
vntField = vntField & Mid$(strLine, _
lngStart, lngDPos - lngStart)
lngStart = lngDPos + 1
Select Case Mid$(strLine, lngStart, 1)
Case ""
Exit Do
Case strDelimiter
lngStart = lngStart + 1
Exit Do
Case strQuote
lngStart = lngStart + 1
vntField = vntField & strQuote
End Select
Else
blnMulti = True
vntField = Mid$(strLine, lngStart) & strRet
lngStart = lngLength + 1
Exit Do
End If
Loop
End If
vntData(i) = vntField
vntField = ""
i = i + 1
Loop Until lngLength < lngStart
SplitCsv = vntData()
End Function
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean _
= False) As Boolean
Dim strFilter As String
'フィルタ文字列を作成
strFilter = "RLE File (*.RLE),*.RLE," _
& "CSV File (*.csv),*.csv," _
& "Text File (*.txt),*.txt," _
& "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
& "全て (*.*),*.*"
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames & "{TAB}", False
End If
'「ファイルを開く」ダイアログを表示
vntFileNames _
= Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
Hirofumi
- 04/12/7(火) 19:26 -
