| |
意味の理解が出来ない所が有るので上手く行くか？
全てのフォルダのデータを1つのBookに読み込みます
また、各フォルダのデータは、1枚づつのシートに成ります
｢Voiding｣のカウントは、各シートの最終行の一つ下に書き込まれます
Option Explicit
Public Sub ReadRle()
Dim i As Long
Dim vntFileNames As Variant
Dim lngWrite As Long
Dim vntVoiding As Variant
Dim blnHeader As Boolean
Dim wkbNewBook As Workbook
Dim wksNewSheet As Worksheet
' Application.ScreenUpdating = False
'新規Bookを追加
Set wkbNewBook = Workbooks.Add
'Voidingカウント用の変数を初期化
ReDim vntVoiding(1 To 2, 1 To 2)
vntVoiding(1, 1) = "Voiding小計"
vntVoiding(2, 1) = "Voiding合計"
Do
'ファイルを開くダイアログを表示してファイル名を取得
If GetReadFile(vntFileNames, ThisWorkbook.Path, True) Then
'新規Bookに書き込み用シートを追加
With wkbNewBook.Worksheets
Set wksNewSheet = .Add(After:=.Item(.Count))
End With
'Voidingカウント用の変数をクリア
vntVoiding(1, 2) = 0
'書き込み行の初期値
lngWrite = 1
'先頭行を書き込み
blnHeader = True
'取得したファイル名全てに繰り返し
For i = 1 To UBound(vntFileNames)
'書き込み用シートに出力
CSVRead vntFileNames(i), wksNewSheet, _
vntVoiding, lngWrite, 1, blnHeader, ","
'先頭行をスッキプ
'blnHeader = False
Next i
'Voidingカウント総数用の変数にVoidingカウントを加算
vntVoiding(2, 2) = vntVoiding(2, 2) + vntVoiding(1, 2)
'最終行の１行下にVoidingカウントを書き込み
lngWrite = lngWrite + 1
With wksNewSheet
.Cells(lngWrite, 4).Resize(2, 2).Value = vntVoiding
End With
'ファイル名取得用変数の初期化
vntFileNames = ""
End If
Loop Until MsgBox("続けますか？", vbInformation + vbYesNo, "処理継続") = vbNo
Set wksNewSheet = Nothing
Set wkbNewBook = Nothing
' Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
ByVal 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 dfn As Integer
Dim vntField As Variant
Dim strLine As String
Dim blnMulti As Boolean
Dim strRec As String
dfn = FreeFile
Open strFileName For Input As dfn
Do Until EOF(dfn)
Line Input #dfn, strLine
strRec = strRec & strLine
vntField = SplitCsv(strRec, strDelim, , , blnMulti)
If blnMulti Then
strRec = strRec & vbLf
Else
If blnHeader Then
If vntField(4) = "Voiding" Then
vntTotal(1, 2) = vntTotal(1, 2) + 1
End If
With wksWrite.Cells(lngRow, lngCol)
.Offset.Resize(, UBound(vntField) + 1) = vntField
End With
lngRow = lngRow + 1
End If
strRec = ""
blnHeader = True
End If
Loop
Close #dfn
End Sub
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/5(日) 17:27 -
