| |
この方が幾らか速いと思います
尚、vntFieldの配列は基底が0ですので、mybufより番号が1つ少なく成ります
>また、日付データをWriteで書き出すと、csvには＃日付け＃となってしまい、
>それをこんどは吸い上げると日付けになりません。
>（＃日付け＃の文字列として認識してしまう）どうしたらいいのでしょうか。
また、上記の件も一応処理を行っている積もりです
元のコードも、
For ColmunNum = 1 To 150
Cells(RowNum, ColmunNum) = mybuf(ColmunNum)
Next ColmunNum
を
Cells(RowNum, 1).Resize(, 150).Value = mybuf
とすれば幾らか速く成ると思います
Option Explicit
Public Sub DataRead()
Dim i As Long
Dim vntFileName As Variant
Dim wksResult As Worksheet
Dim lngRow As Long
Dim lngRecNumb As Long
Dim blnWayOut As Boolean
Application.ScreenUpdating = False
'シートに登録するCSVファイルを開く
vntFileName = ActiveWorkbook.Path & "\" & "入力データ.csv"
'データを登録していくシート
Set wksResult = Worksheets("登録")
With wksResult
lngRow = .Cells(65536, "C").End(xlUp).Row
If lngRow = 1 Then
If .Cells(lngRow, "C").Value = "" Then
lngRow = 0
End If
End If
lngRow = lngRow + 1
lngRecNumb = Val(.Cells(lngRow, "C").Value) + 1
End With
blnWayOut = CSVRead(vntFileName, wksResult, lngRecNumb, lngRow, 1)
Set wksResult = Nothing
Application.ScreenUpdating = True
Beep
If blnWayOut Then
MsgBox "処理が終了しました"
Else
MsgBox "データが不正のため終了"
End If
End Sub
Private Function CSVRead(ByVal strFileName As String, _
ByVal wksWrite As Worksheet, _
ByRef lngRecNumb As Long, _
Optional ByRef lngRow As Long = 1, _
Optional ByRef lngCol As Long = 1) As Boolean
Dim dfn As Integer
Dim vntField As Variant
Dim strLine As String
Dim blnMulti As Boolean
Dim strRec As String
CSVRead = True
dfn = FreeFile
Open strFileName For Input As dfn
Do Until EOF(dfn)
Line Input #dfn, strLine
strRec = strRec & strLine
vntField = SplitCsv(strRec, ",", , , blnMulti)
If blnMulti Then
strRec = strRec & vbLf
Else
If DataCheck(vntField) Then
vntField(2) = lngRecNumb
vntField(3) = Format(vntField(3), "&&&&/&&/&&")
vntField(103) = Format(vntField(103), "&&&&/&&/&&")
With wksWrite.Cells(lngRow, lngCol)
.Resize(, UBound(vntField) + 1) = vntField
End With
lngRow = lngRow + 1
lngRecNumb = lngRecNumb + 1
strRec = ""
Else
CSVRead = False
Exit Do
End If
End If
Loop
Close #dfn
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)
If lngDPos = lngLength Then
ReDim Preserve vntData(i + 1)
End If
lngStart = lngDPos + 1
Else
vntField = Mid$(strLine, lngStart)
lngStart = lngLength + 1
End If
If Left$(vntField, 1) = "#" _
And Right$(vntField, 1) = "#" Then
If IsDate(Mid$(vntField, 2, _
Len(vntField) - 2)) Then
vntField = CDate(Mid$(vntField, _
2, Len(vntField) - 2))
End If
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 = Empty
i = i + 1
Loop Until lngLength < lngStart
SplitCsv = vntData()
End Function
Private Function DataCheck(vntField As Variant) As Boolean
If Len(vntField(0)) <> 3 Then
Exit Function
End If
If Len(vntField(3)) <> 8 Then
Exit Function
End If
If Len(vntField(14)) <> 3 Then
Exit Function
End If
If Len(vntField(15)) <> 1 Then
Exit Function
End If
If Len(vntField(16)) <> 1 Then
Exit Function
End If
If Len(vntField(29)) <> 2 Then
Exit Function
End If
If Len(vntField(30)) <> 2 Then
Exit Function
End If
If Len(vntField(34)) <> 2 Then
Exit Function
End If
If Len(vntField(35)) <> 2 Then
Exit Function
End If
If Len(vntField(98)) <> 3 Then
Exit Function
End If
If Len(vntField(103)) <> 8 Then
Exit Function
End If
If Len(vntField(110)) <> 2 Then
Exit Function
End If
DataCheck = True
End Function
|
|
Hirofumi
- 05/2/12(土) 20:11 -
