Excel VBA質問箱 IV

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

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


10377 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

【22219】csvファイル入力について
質問  wada  - 05/2/12(土) 10:51 -

引用なし
パスワード
   初心者です。エクセルでデータベースを作成中ですが、データをCSVで吸い上げるときにえらい時間がかかります。1レコード150フィールドがあり、Writeステートメントで書き出したものを、Writeステートメントの対になるステートメント(名前忘れました)で読み込んでいます。吸い込み先シートにデータがすくなければ比較的早いのですが、シートにデータが数千件以上もあると、1件読み込むのに5秒くらいかかることがあります。数百件のデータを読み込むと数時間かかってしまいます。ここで、もっと効率的に早く読み込む方法はありませんか。(シートにデータが多いと、なぜ遅くなるのでしょうか。)また、日付データをWriteで書き出すと、csvには#日付け#となってしまい、それをこんどは吸い上げると日付けになりません。(#日付け#の文字列として認識してしまう)どうしたらいいのでしょうか。

【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 -

引用なし
パスワード
   コードは下記のようになっております。
150フィールド分のcsvを読み込みます。
3列目の受理番号は、シート既存のデータの最終行の受理番号に+1を加算していきます。
4列目と104列目は日付フィールドでcsvファイルのYYYYMMDD形式のテキストファイルを日付データに変換していきます。

Sub CSVファイル登録()

Dim RowNum As Long
Dim ColmunNum As Long
Dim EndjuriNum As Long
Dim myTxtFile As String

'データを登録していくシート
Worksheets("登録").Activate

'シートの最終行を選択
Cells(1, 3).Select
Selection.End(xlDown).Select
EndjuriNum = Cells(Selection.Cells.Row, 3).Value
RowNum = Selection.Row

'シートに登録するCSVファイルを開く、150のフィールド用にカンマで区切られている
myTxtFile = ActiveWorkbook.Path & "\入力データ.csv"
    
    Open myTxtFile For Input As #1
    
    Do Until EOF(1)
    
    
      '1から164列までのデータを変数に入れる
      Dim mybuf(1 To 150) As String
      Dim i As Integer
      
      For i = 1 To 150
        Input #1, mybuf(i)
      Next i
      
      '必須項目が不正であれば入力をはじく、桁数で判定
     If Len(mybuf(1)) <> 3 Or Len(mybuf(4)) <> 8 Or Len(mybuf(15)) <> 3 Or Len(mybuf(16)) <> 1 Or _
      Len(mybuf(17)) <> 1 Or Len(mybuf(30)) <> 2 Or Len(mybuf(31)) <> 2 Or Len(mybuf(35)) <> 2 Or _
      Len(mybuf(36)) <> 2 Or Len(mybuf(36)) <> 2 Or Len(mybuf(99)) <> 3 Or Len(mybuf(104)) <> 8 Or _
      Len(mybuf(111)) <> 2 Then
      
      MsgBox "データが不正のため終了"
      Close #1
      Exit Sub
     End If
      
      '3列目は受理番号、前レコードの受理番号に1を加算していく
      mybuf(3) = EndjuriNum + 1
      
      '4列目と104列目は日付フィールド、YYYYMMDDのテキスト形式から日付データに変換
      mybuf(4) = Left(mybuf(4), 4) & "/" & Mid(mybuf(4), 5, 2) & "/" & Right(mybuf(4), 2)
      mybuf(104) = Left(mybuf(104), 4) & "/" & Mid(mybuf(104), 5, 2) & "/" & Right(mybuf(104), 2)
      
      RowNum = RowNum + 1

      For ColmunNum = 1 To 150
        Cells(RowNum, ColmunNum) = mybuf(ColmunNum)
      Next ColmunNum
      
      EndjuriNum = EndjuriNum + 1
    
    Loop
    
    Close #1

End Sub

以上がおおまかなコードですが、これを処理時間を短縮できるような方法を教えてください。(効率いい方法を)

【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

【22243】Re:csvファイル入力について
お礼  wada  - 05/2/13(日) 1:27 -

引用なし
パスワード
   ▼Hirofumi さん:
格段に登録速度が速くなりました。
「Cells(RowNum, 1).Resize(, 150).Value = mybuf」の部分だけでもだいぶ違うのですね。
ありがとうございました。

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