Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


59211 / 76732 ←次へ | 前へ→

【22231】Re:csvファイル入力について
回答  Hirofumi  - 05/2/12(土) 20:11 -

引用なし
パスワード
   この方が幾らか速いと思います
尚、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

0 hits

【22219】csvファイル入力について wada 05/2/12(土) 10:51 質問
【22220】Re:csvファイル入力について かみちゃん 05/2/12(土) 10:56 発言
【22222】Re:csvファイル入力について wada 05/2/12(土) 11:04 発言
【22225】Re:csvファイル入力について wada 05/2/12(土) 15:56 質問
【22231】Re:csvファイル入力について Hirofumi 05/2/12(土) 20:11 回答
【22243】Re:csvファイル入力について wada 05/2/13(日) 1:27 お礼

59211 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free