Excel VBA質問箱 IV

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

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


60977 / 76732 ←次へ | 前へ→

【20382】Re:同一フォルダ内に保存しているファイルをEXCELシートに追加読み込み
回答  Hirofumi  - 04/12/7(火) 19:26 -

引用なし
パスワード
   >下記の「If vntField(4) = "Voiding" Then」で止まってしまいます。

どの様な、止まり方をしているのが不明なので、善く解りませんが?
多分、データが、5フィールド分無いのでは?
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
1 hits

【20321】同一フォルダ内に保存しているファイルをEXCELシートに追加読み込み ムシキング 04/12/5(日) 14:40 質問
【20324】Re:同一フォルダ内に保存しているファイル... [名前なし] 04/12/5(日) 15:01 発言
【20326】Re:同一フォルダ内に保存しているファイル... ムシキング 04/12/5(日) 15:27 発言
【20328】Re:同一フォルダ内に保存しているファイル... [名前なし] 04/12/5(日) 16:33 回答
【20329】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/5(日) 17:27 回答
【20330】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/5(日) 21:50 回答
【20331】Re:同一フォルダ内に保存しているファイル... ムシキング 04/12/5(日) 23:22 発言
【20344】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/6(月) 19:15 回答
【20345】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/6(月) 19:22 回答
【20346】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/6(月) 19:40 回答
【20348】Re:同一フォルダ内に保存しているファイル... ムシキング 04/12/6(月) 22:41 質問
【20382】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/7(火) 19:26 回答
【20477】Re:同一フォルダ内に保存しているファイル... ムシキング 04/12/9(木) 23:01 発言
【20515】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/10(金) 21:04 回答
【20676】Re:同一フォルダ内に保存しているファイル... ムシキング 04/12/14(火) 20:39 お礼
【20677】Re:同一フォルダ内に保存しているファイル... Hirofumi 04/12/14(火) 21:17 回答

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