Excel VBA質問箱 IV

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

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


53180 / 76732 ←次へ | 前へ→

【28371】Re:外部ファイルの自動読み込みについて
質問  ミツコ  - 05/9/4(日) 9:14 -

引用なし
パスワード
   後半


Private Sub Workbook_Open()

  '実行間隔指定(10分間隔)
  Application.OnTime Time + TimeValue("00:00:15"), "Execution"
 
End Sub

Private Sub Execution()
 
  '終了時間設定
  If Time < #5:30:00 PM# Then
    CrossTabulation
    SetTimer
  End If
 
End Sub

Public Sub CrossTabulation()

  '日付の先頭位置の前の列
  Const clngTop As Long = 11
  'ファイル名Listの有るシート名
  Const cstrList As String = "FileList"
 
  Dim i As Long
  Dim j As Long
  Dim strPath As String
  Dim vntFileNames As Variant
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim lngCol As Long
  Dim lngRow As Long
  Dim rngScope As Range
  Dim rngResult As Range
  Dim rngDate As Range
  Dim wksFiles As Worksheet
  Dim rngLog As Range
  Dim lngLog As Long
  Dim vntLog(3) As Variant
 
  'ファイル名Listの有るシートの確認
  FileListCheck cstrList, wksFiles
  'Log書き込み位置指定
  Set rngLog = wksFiles.Cells(2, "D")
  With rngLog
    lngLog = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
  End With
 
  'Textファイルの有るフォルダを指定
  strPath = "C:\system"

  '読み込むファイルを取得(ダイアログを出さないで、指定フォルダから取得の場合)
  If Not GetAppendFile(vntFileNames, strPath, "txt", _
 "^[0-9][0-9][0-9][0-9][0-9][0-9]da~["", 0-9]*$", wksFiles) Then  '←修正してみました。
    GoTo Wayout
  End If
 
'  Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(7, "A")
  With rngResult
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
            - .Offset(, clngTop).Column
    '日付列の範囲を取得
    If lngCol > 0 Then
      Set rngDate = .Offset(, clngTop + 1).Resize(, lngCol)
    End If
    'No.が有る行数を取得
    lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'No.が有る範囲を取得
    If lngRow > 0 Then
      Set rngScope = .Offset(1).Resize(lngRow)
    End If
  End With

  For i = 1 To UBound(vntFileNames)
    j = 0
    '指定されたファイルをOpen
    dfn = FreeFile
    Open vntFileNames(i) For Input As dfn
    'ファイルから日付を取得
    Do Until EOF(dfn)
      'ファイルから1行読み込み
      Line Input #dfn, strBuff
      j = j + 1
      'フィールドに分割
      vntField = Split(strBuff, ",", , vbBinaryCompare)
      '「20050731」形式の日付をシリアル値に変換
      vntField(0) = CLng(DateValue(Left(vntField(0), 4) _
                & "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)))
      '日付を探索
      lngCol = GetDateColumn(vntField(0), rngDate, _
                rngResult.Offset(, clngTop)) + clngTop
      If lngCol = 0 + clngTop Then


        '日付が表に無く中止した場合、Logを出力
        vntLog(0) = Date
        vntLog(1) = Time
        vntLog(2) = vntFileNames(i)
        vntLog(3) = j & "行目、" & Format(vntField(0), "yyyy/m/d") _
                & " 日付無しに因り読み込み中止"
        rngLog.Offset(lngLog).Resize(, 4).Value = vntLog
        lngLog = lngLog + 1
        Exit Do
      Else
        'No.を探索
        lngRow = GetTagNoRow(vntField(5), rngScope, rngResult)
        '日付、Noの交差するセルに値を書き込み
        With rngResult.Offset(lngRow, lngCol)
          .NumberFormatLocal = "G/標準"
          .Value = vntField(6)
        End With
      End If
    Loop
    Close #dfn
  Next i

Wayout:

'  Application.ScreenUpdating = True

  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing
  Set wksFiles = Nothing
  Set rngLog = Nothing
 
  Beep

End Sub
Private Sub FileListCheck(strSheet As String, wksFiles As Worksheet)

  Dim blnExist As Boolean
 
  With ThisWorkbook
    For Each wksFiles In .Worksheets
      If StrComp(wksFiles.Name, _
          strSheet, vbTextCompare) = 0 Then
        blnExist = True
        Exit For
      End If
    Next wksFiles
    If Not blnExist Then
      With .Worksheets
        Set wksFiles = .Add(After:=.Item(.Count))
        wksFiles.Name = strSheet
      End With
    End If
  End With

End Sub

Private Function GetAppendFile(vntFileNames As Variant, _
              strFilePath As String, _
              strExtePattan As String, _
              strNamePattan As String, _
              wksFiles As Worksheet) As Boolean

  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim dicIndex As Object
  Dim rngList As Range
  Dim vntData As Variant
  Dim vntAppend() As Variant
  Dim vntRead As Variant
 
  Set rngList = wksFiles.Cells(2, "A")
 
  '読み込むファイル名を取得
  If Not GetFilesList(vntRead, strFilePath, _
              strExtePattan, strNamePattan) Then
    GoTo Wayout
  End If
 
  With rngList
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
    If lngRows < 1 Then
      lngRows = 0
    Else
      vntData = .Resize(lngRows).Value
      ReDim Preserve vntData(1 To lngRows, 1 To 2)
    End If
  End With
  
  Set dicIndex = CreateObject("Scripting.Dictionary")
  With dicIndex
    For i = 1 To lngRows
      .Add vntData(i, 1), i
    Next i
    j = 0
    For i = 1 To UBound(vntRead)
      If .Exists(vntRead(i)) Then
        vntData(.Item(vntRead(i)), 2) = "*"
      Else
        j = j + 1
        ReDim Preserve vntAppend(1 To j)
        vntAppend(j) = vntRead(i)
      End If
    Next i
  End With
  Set dicIndex = Nothing
 
  If j > 0 Then
    vntFileNames = vntAppend
    GetAppendFile = True
  End If
 
  'データ全てに就いて繰り返し
  j = 0
  For i = 1 To lngRows
    'もし、対象データが""で無いなら
    If vntData(i, 2) <> "" Then
      '書き込み位置を更新
      j = j + 1
      '配列の対象位置のデータを書き込み位置に代入
      vntData(j, 1) = vntData(i, 1)
      vntData(j, 2) = vntData(i, 2)
    End If
  Next i
 
  With rngList
    If lngRows > 0 Then
      .Resize(lngRows, 2).ClearContents
      .Resize(j, 2).Value = vntData
    End If
    If VarType(vntFileNames) = vbArray + vbVariant Then
      .Offset(j).Resize(UBound(vntFileNames)).Value _
          = Application.Transpose(vntFileNames)
    End If
  End With
 
Wayout:
 
  Set rngList = Nothing
 
End Function

Private Function GetFilesList(vntFileNames As Variant, _
              strFilePath As String, _
              Optional strExtePattan As String = ".*", _
              Optional strNamePattan As String = ".*") As Boolean
 
  Dim i As Long
  Dim objFiles As Object
  Dim objFile As Object
  Dim regExten As Object
  Dim regName As Object
  Dim vntRead() As Variant
  Dim strName As String
  Dim objFso As Object
 
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
  
  'フォルダの存在確認
  If Not objFso.FolderExists(strFilePath) Then
    GoTo Wayout
  End If
 
  'regExtenpのオブジェクトを取得(正規表現を作成)
  Set regExten = CreateObject("VBScript.RegExp")
  With regExten
    'パターンを設定
    .Pattern = strExtePattan
    '大文字と小文字を区別しないように設定
    .IgnoreCase = True
  End With
  Set regName = CreateObject("VBScript.RegExp")
  With regName
    'パターンを設定
    .Pattern = strNamePattan
    '大文字と小文字を区別しないように設定
    .IgnoreCase = True
  End With
 
  'フォルダオブジェクトを取得
  Set objFiles = objFso.GetFolder(strFilePath).Files
 
  'ファイルの数が0でなければ
  If objFiles.Count <> 0 Then
    For Each objFile In objFiles
      With objFile
        strName = .Name
        '検索をテスト
        If regExten.Test(objFso.GetExtensionName(strName)) Then
          If regName.Test(objFso.GetBaseName(strName)) Then
            i = i + 1
            ReDim Preserve vntRead(1 To i)
            vntRead(i) = strName
          End If
        End If
      End With
    Next objFile
  End If
 
  Set regExten = Nothing
  Set regName = Nothing
 
  If i <> 0 Then
    ReDim vntFileNames(1 To UBound(vntRead))
    For i = 1 To UBound(vntRead)
      vntFileNames(i) _
        = StrConv(strFilePath & "\" & vntRead(i), vbNarrow)
    Next i
    GetFilesList = True
  End If
 
Wayout:

  'フォルダオブジェクトを破棄
  Set objFiles = Nothing
  Set objFile = Nothing
  Set objFso = Nothing
 
End Function


End Function

0 hits

【28362】外部ファイルの自動読み込みについて ミツコ 05/9/3(土) 17:46 質問
【28367】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 2:15 回答
【28368】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 2:17 回答
【28370】Re:外部ファイルの自動読み込みについて ミツコ 05/9/4(日) 9:13 質問
【28371】Re:外部ファイルの自動読み込みについて ミツコ 05/9/4(日) 9:14 質問
【28372】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 10:36 回答
【28373】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 11:18 発言
【28374】Re:外部ファイルの自動読み込みについて ミツコ 05/9/4(日) 11:31 質問
【28375】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 13:30 回答
【28376】Re:外部ファイルの自動読み込みについて ミツコ 05/9/4(日) 17:50 質問
【28377】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 19:12 回答
【28378】Re:外部ファイルの自動読み込みについて ミツコ 05/9/4(日) 20:06 質問
【28379】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 21:11 回答
【28751】Re:外部ファイルの自動読み込みについて ミツコ 05/9/13(火) 22:42 質問
【28796】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/14(水) 21:35 回答
【28753】Re:外部ファイルの自動読み込みについて ミツコ 05/9/13(火) 22:48 質問
【32249】Hirofumiさん教えてください。 ミツコ 05/12/11(日) 11:15 質問
【32250】現在利用しているコードも記載します1. ミツコ 05/12/11(日) 11:27 質問
【32251】現在利用しているコードも記載します2. ミツコ 05/12/11(日) 11:28 質問
【32252】Re:現在利用しているコードも記載します2. Hirofumi 05/12/11(日) 13:00 回答
【32273】Re:現在利用しているコードも記載します2. ミツコ 05/12/12(月) 1:56 お礼

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