Excel VBA質問箱 IV

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

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


8614 / 13644 ツリー ←次へ | 前へ→

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

【28362】外部ファイルの自動読み込みについて
質問  ミツコ  - 05/9/3(土) 17:46 -

引用なし
パスワード
   同様の質問が過去にありませんでしたのでお願いします。

下記マクロでC:\system にあるCSVファイルを読み込もうと思います。

しかしダイアログを開いてファイルを選択するのではなく
C:\system にCSVファイルが追加されたら自動的に読み込む
或いは一定時間ごとにC:\systemに新しく追加されたファイルを読みに行く
などの動作にしたく思います。

どのようにすればよいかご指導をお願いします。

補足
・CSVファイルは毎日不定期にC:\systemフォルダに追加されます。
 ファイル名は050903~1.txt、050903~2.txt、・・・ という具合で

・エクセルは常時稼動させておきます。

何卒よろしくお願いいたします。


Option Explicit

Public Sub データ収集()

  '日付の先頭位置の前の列
  Const clngTop As Long = 11

  Dim strPath As String
  Dim vntFileName 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 strProm As String
  Dim strNoMatch As String

  'Textファイルの有るフォルダを指定
  strPath = "C:\system"

  '「ファイルを開く」ダイアログを表示
  If Not GetReadFile(vntFileName, strPath, False) Then
    strProm = "マクロがキャンセルされました"
    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

  '指定されたファイルをOpen
  dfn = FreeFile
  Open vntFileName For Input As dfn

  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    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

      '該当日付が無い場合、メセージを出し直ちに終了する
      strProm = Format(vntField(0), "m/d") & " の日付が有りません。"
      GoTo WayOut
    Else
      'No.を探索
      lngRow = GetTagNoRow(vntField(5), rngScope, rngResult)
      '日付、Noの交差するセルに値を書き込み
      With rngResult.Offset(lngRow, lngCol)
        .NumberFormatLocal = "G/標準"
        .Value = vntField(6)
      End With
    End If
  Loop

  If strNoMatch = "" Then
    strProm = "処理が完了しました"
  Else
    strProm = "以下の該当しない日付がファイルに存在します" & vbCrLf & strNoMatch
  End If
  
WayOut:

  Close #dfn
 
  Application.ScreenUpdating = True

  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing

  Beep
  MsgBox strProm

End Sub


Private Function GetDateColumn(vntDate As Variant, _
                rngScope As Range, _
                rngDateTop As Range) As Long

  Dim lngFound As Long
  Dim lngOver As Long
  Dim lngCount As Long
 
  '日付範囲に日付が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
    lngOver = 1
  Else
    '日付の探索
    'セル値が数値として入力されている場合
    lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
    'セル値が文字列として入力されている場合
'    lngFound = DataSearch(vntDate, rngScope, lngOver)
    lngCount = rngScope.Columns.Count
  End If
 
  '日付が見つかった場合
  If lngFound > 0 Then
    '位置を返す
    GetDateColumn = lngFound
  Else
    With rngDateTop
      '日付が最終列の以内の場合
      If lngOver <= lngCount Then
        '指定位置に列を挿入
        .Offset(, lngOver).EntireColumn.Insert
      End If
      '日付を書き込み
      With .Offset(, lngOver)
        .NumberFormatLocal = "m/d"
        .Value = vntDate
      End With
      '挿入位置を返す
      GetDateColumn = lngOver
      '日付列の範囲を更新
      Set rngScope _
        = .Offset(, 1).Resize(, lngCount + 1)
    End With
  End If
 
End Function

Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Long
  Dim lngCount As Long

  'No範囲にNoが無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
  Else
    'Noを探索
    lngFound = DataSearch(vntTagNo, rngScope, , 0)
    lngCount = rngScope.Rows.Count
  End If

  '探索成功(Noが有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetTagNoRow = lngFound
  Else
    With rngListTop
      '行末位置を更新
      lngCount = lngCount + 1
      '行末にNoを書き込み
      .Offset(lngCount).Value = vntTagNo
      '挿入位置を返す
      GetTagNoRow = lngCount
      '探索範囲の更新
      Set rngScope _
        = .Offset(1).Resize(lngCount)
    End With
  End If

End Function

Private Function DataSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long, _
            Optional lngMode As Long = 1) As Long

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, lngMode)
  lngOver = 1
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      DataSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  End If

End Function

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

  Dim strFilter As String

  'フィルタ文字列を作成
  strFilter = "Text File (*.txt),*.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, 2, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If

  GetReadFile = True

End Function

【28367】Re:外部ファイルの自動読み込みについて
回答  Hirofumi  - 05/9/4(日) 2:15 -

引用なし
パスワード
   指定フォルダからTextファイルを読み込む様に改造して見ました
改変に共ない、指定フォルダの読み込み済み、ファイルを区別する為
マクロの有るBookに、FileListと言うシートが作られ、
ファイルのリストが作成されます
尚、一定時間毎にフォルダを探索するコードは作った事が無いので
上手く行かないかも?
現状では、「Sub SetTimer」を実行すると、10分間隔で17時30分まで動く様に
成ってますが、直近の時間で試して下さい
(動かすと時間に成らないと、止め様が無いかも?)

また、データも、シートのレイアウトも無いのでTestはしていません


以下のプロシージャは、使用しないので削除
Private Function GetReadFile

以下のプロシージャは、変更が無いので其のまま使用
Private Function GetDateColumn
Private Function GetTagNoRow
Private Function DataSearch

以下のプロシージャは、新規追加
Public Sub SetTimer
Private Sub Execution
Private Sub FileListCheck
Private Function GetAppendFile
Private Function GetFilesList

以下のプロシージャは、変更
Public Sub CrossTabulation(旧名 Public Sub データ収集())


Option Explicit

Public Sub SetTimer()

  '実行間隔指定(10分間隔)
  Application.OnTime Time + TimeValue("00:10:00"), "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]~[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

以下後半に続く

【28368】Re:外部ファイルの自動読み込みについて
回答  Hirofumi  - 05/9/4(日) 2:17 -

引用なし
パスワード
   前半より

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

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

引用なし
パスワード
   Hirofumi さん ありがとうございます。


前半より

1、Private Sub Workbook_Open() に変更させて頂きました。

2、読み込むファイル名が間違っていましたのでマクロを修正しました。
  ファイル名は、その日の1番最初が050901da.txt、2番目が050901da~1.txt
  3番目が050901da~2.txtという具合で追加されていきます。


3、また下記の部分でsubまたはfunctionが定義されていません。
  と表示されます。何が原因でしょうか?

 '日付を探索
  lngCol = GetDateColumn(vntField(0), rngDate, _
    rngResult.Offset(, clngTop)) + clngTop


CSVファイル(C:\system)
20050901,1001,0,0,1,003,1800
20050901,1003,0,0,1,001,1850
20050901,1005,0,0,1,005,1780
20050901,1010,0,0,1,002,1600
20050901,1015,0,0,1,013,1700
20050901,1020,0,0,1,008,1760
20050901,1025,0,0,1,012,1690
20050901,1030,0,0,1,006,1730

エクセルフォーマット(シート1)
  A  B  C  D  E ・・・M    N  ・・・




7 No  名称 区分 分類 ・・・・日付読込 日付読込 ・・・
8 001              deta読込 出た読込 ・・・ 
9 002              deta読込 出た読込 ・・・ 
10 003              deta読込 出た読込 ・・・ 
11 004              deta読込 出た読込 ・・・ 
12 005              deta読込 出た読込 ・・・ 
13 006              deta読込 出た読込 ・・・ 
  ・
  ・

マクロは後半に掲載します。

【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

【28372】Re:外部ファイルの自動読み込みについて
回答  Hirofumi  - 05/9/4(日) 10:36 -

引用なし
パスワード
   取り合えず、以下を確認したいのですが?

>1、Private Sub Workbook_Open() に変更させて頂きました。

何を、「Private Sub Workbook_Open() に変更させて頂きました。」に変更したのですか?
此れが解らないと、マクロが正常に動くのか動かないのか解りません
至急お知らせ下さい

>2、読み込むファイル名が間違っていましたのでマクロを修正しました。
>  ファイル名は、その日の1番最初が050901da.txt、2番目が050901da~1.txt
>  3番目が050901da~2.txtという具合で追加されていきます。

此れに就いて、渡しは、正規表現を余り使った事が無いのでこれから確認して見ます

>3、また下記の部分でsubまたはfunctionが定義されていません。
>  と表示されます。何が原因でしょうか?
>
> '日付を探索
>  lngCol = GetDateColumn(vntField(0), rngDate, _
>    rngResult.Offset(, clngTop)) + clngTop

此れに就いて、今回、新規、修正プロシージャがUpするには、
かなり大きく成ってしまいましたので全文で載せていません
前半部に書いたのですが、以下のプロシージャは、
ミツコさんがUpした物と変更が無いので其方からCopyして
同じ標準モジュールに入れて下さい

以下のプロシージャは、変更が無いので其のまま使用
Private Function GetDateColumn
Private Function GetTagNoRow
Private Function DataSearch

【28373】Re:外部ファイルの自動読み込みについて
発言  Hirofumi  - 05/9/4(日) 11:18 -

引用なし
パスワード
   今、コードをザッと確認して解った事なのですが?
ミツコさんが最初にUpしたコードは、
以前、別な方に付けたレスの最終仕様のコードと
其の一つ前の仕様のコードを混ぜた物ですね?
此れだと、引数の違い、プロシージャの組み立ての違いで
希望する動作に成らない様な気がします
ここら辺をもう一度チェックしますので
メインの「Public Sub CrossTabulation」は変更に成ると思います

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

引用なし
パスワード
   ▼Hirofumi さん ありがとうございます。

Private Sub Workbook_Open() について
間違いに気がつきました。

パソコンを起動、或いはBOOKを開いたときに
シート1に対しマクロをを実行させたいのですが
どのようにするのが良いでしょうか

【28375】Re:外部ファイルの自動読み込みについて
回答  Hirofumi  - 05/9/4(日) 13:30 -

引用なし
パスワード
   一応、Upされたレイアウトとデータに因り、
「Public Sub CrossTabulation」のTestをして見た結果の修正変更をUpします

1、「Public Sub CrossTabulation()」に就いては、
 変更箇所が多いのでこのプロシージャ全文を載せます

Public Sub CrossTabulation()

  '日付の先頭位置の前の列
  Const clngTop As Long = 11
  'ファイル名Listの有るシート名
  Const cstrList As String = "FileList"

  Dim i 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

  'ファイル名Listの有るシートの確認
  FileListCheck cstrList, wksFiles

  '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][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)
    '指定されたファイルをOpen
    dfn = FreeFile
    Open vntFileNames(i) For Input As dfn
    'ファイルから日付を取得
    Do Until EOF(dfn)
      'ファイルから1行読み込み
      Line Input #dfn, strBuff
      'フィールドに分割
      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
      'No.を探索
      lngRow = GetTagNoRow(vntField(5), rngScope, rngResult)
      '日付、Noの交差するセルに値を書き込み
      With rngResult.Offset(lngRow, lngCol)
        .NumberFormatLocal = "G/標準"
        .Value = vntField(6)
      End With
    Loop
    Close #dfn
  Next i

Wayout:

  Application.ScreenUpdating = True

  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing
  Set wksFiles = Nothing

  Beep

End Sub

尚、日付は、追加する形に成る為、Log出力はしません

2、「Private Function GetTagNoRow」は、以下を追加

    With rngListTop
      '行末位置を更新
      lngCount = lngCount + 1
      'セルの書式を文字列に設定
      '(001の様な場合無いと探索が出来ない)
      .Offset(lngCount).NumberFormatLocal = "@" '★追加行
      '行末にNoを書き込み

 尚、Noを昇順に並べて行く様にするなら、プロシージャを以下の物と差し替えて下さい

Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Long
  Dim lngOver As Long
  Dim lngCount As Long

  '商品名範囲に商品名が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
    lngOver = 1
  Else
    '商品名を探索
    lngFound = DataSearch(vntTagNo, rngScope, lngOver)
    lngCount = rngScope.Rows.Count
  End If

  '探索成功(商品名が有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetTagNoRow = lngFound
  Else
    With rngListTop
      '挿入位置が行末で無いなら
      If lngOver <= lngCount Then
        '行を挿入
        .Offset(lngOver).EntireRow.Insert
      End If
      'セルの書式を文字列に設定
      .Offset(lngOver).NumberFormatLocal = "@" '★追加行
      '商品名を書き込み
      .Offset(lngOver).Value = vntTagNo
      '挿入位置を返す
      GetTagNoRow = lngOver
      '探索範囲の更新
      Set rngScope _
        = .Offset(1).Resize(lngCount + 1)
    End With
  End If

End Function

3、「Private Function GetAppendFile」は不都合が有る為、
 以下の部分を3行追加、1行削除して下さい

  With rngList
    If lngRows > 0 Then
      .Resize(lngRows, 2).ClearContents
'      .Resize(j, 2).Value = vntData '☆削除行
    End If
    If j > 0 Then '◎追加行
      .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:

4、テストする時は、必ず「Public Sub CrossTabulation()」の方を先にして下さい
 タイマー関連は、後回しにする
 また、一度動かすと、マクロの有るBookに「FileList」と言うシートができ
 其処に、読み込んだファイル名が書き込まれます
 ここに、表示されているファイルは、次回は読み込まれないので、
 テストの時は、このファイル名を削除して下さい

5、
>Private Sub Workbook_Open() について
>間違いに気がつきました。
>
>パソコンを起動、或いはBOOKを開いたときに
>シート1に対しマクロをを実行させたいのですが
>どのようにするのが良いでしょうか

「パソコンを起動」した時はどうしようも有りませんが?
(実際は、タスクスケジュラー等でやれる様なきもしますが?)
「BOOKを開いたとき」は、ThisWorkBookのコードモジュールに

Option Explicit

Private Sub Workbook_Open()

  CrossTabulation
  
End Sub

とすれば実行出きると思います

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

引用なし
パスワード
   Hirofumi さん ありがとうございます。

いろいろ試させていただきました。
一応動作はしていまして

しかし不具合がありまして
1、C:\systemにファイルが1個しかない場合、2順目のマクロ実行でエラーになる。
2、他のシートで作業中にC:\systemにファイルを追加するとエラーになる。
  (データーの書き込む場所をシート1に指定していないからでしょうか?)

改良に挑戦していますが苦戦です。


それから疑問に思った点ですが C:\system にファイルが何百個、何千個と増えたら動作が遅くなると思いますが、何か良いアイデアはありませんでしょうか


下記は未だ試していません。
Option Explicit

Private Sub Workbook_Open()

  CrossTabulation
  
End Sub

【28377】Re:外部ファイルの自動読み込みについて
回答  Hirofumi  - 05/9/4(日) 19:12 -

引用なし
パスワード
   >しかし不具合がありまして
>1、C:\systemにファイルが1個しかない場合、2順目のマクロ実行でエラーになる。

これは、「Private Function GetAppendFile」にバグが有り起きているのが解りました
以下に修正箇所をUpします

修正箇所
「Private Function GetAppendFile」の中で
 削除行2ヵ所、追加行3箇所です

  '読み込むファイル名を取得
  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) '☆削除
      If lngRows = 1 Then '★追加行
        ReDim vntData(1 To lngRows, 1 To 2) '★追加行
        vntData(lngRows, 1) = .Resize(lngRows).Value '★追加行
      Else '★追加行
        vntData = .Resize(lngRows).Value '★追加行
        ReDim Preserve vntData(1 To lngRows, 1 To 2) '★追加行
      End If '★追加行
    End If
  End With

>2、他のシートで作業中にC:\systemにファイルを追加するとエラーになる。
>  (データーの書き込む場所をシート1に指定していないからでしょうか?)

此れに就いては、意味が善く解らないのですが?
たしかに、「Private Function GetFilesList」が動いている時にファイルが追加されれば
エラーを起こすのかな?とも思われますが、
「Private Function GetFilesList」が動いているのは、1秒程度(多分、数分の1秒)でしょうから
確率的には?
ただし、C:\systemに数千数万のファイル(txtファイルに限らず)が有れば別ですが?

>改良に挑戦していますが苦戦です。
>
>
>それから疑問に思った点ですが C:\system にファイルが何百個、
>何千個と増えたら動作が遅くなると思いますが、
>何か良いアイデアはありませんでしょうか

運用の問題ですので特に有りませんね?
ただ、数百個程度なら特に遅くは無いのでは?

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

引用なし
パスワード
   Hirofumi さん ありがとうございます。

下記の件ですがどうしても直らないんでよね(困)
他のシートを開いていると、そこにデータが書き込まれてしまうんです。


>>2、他のシートで作業中にC:\systemにファイルを追加するとエラーになる。
>>  (データーの書き込む場所をシート1に指定していないからでしょうか?)

>此れに就いては、意味が善く解らないのですが?


それから
FileListには65000件程度のファイル名の記録が可能ということになりますでしょうか?

【28379】Re:外部ファイルの自動読み込みについて
回答  Hirofumi  - 05/9/4(日) 21:11 -

引用なし
パスワード
   >下記の件ですがどうしても直らないんでよね(困)
>他のシートを開いていると、そこにデータが書き込まれてしまうんです。
>
>
>>>2、他のシートで作業中にC:\systemにファイルを追加するとエラーになる。
>>>  (データーの書き込む場所をシート1に指定していないからでしょうか?)
>
>>此れに就いては、意味が善く解らないのですが?
>

まだ状況、意味が善く解りませんが?
ただ単に、出力するシートを固定したいのなら、それは簡単に出来ますよ
変更ヵ所は、1ヵ所だけです
また、このコードの出力は、コードの有るBookだけに限りません
1ヵ所の変更だけで違うBook(開いてあれば)に出力する事もできます

「Public Sub CrossTabulation()」の中で

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(7, "A")

と成って居るので、ActiveSheetに出力されるだけで

  'Sheet1のA1セルを基準とする(Listの左上隅)場合
  Set rngResult = WorkSheets("Sheet1").Cells(7, "A")

とすれば、ActiveWorkBookの"Sheet1”に出力されますし

  'ThisWorkBookの"Sheet1"のA1セルを基準とする(Listの左上隅)場合
  Set rngResult = ThisWorkBook.WorkSheets("Sheet1").Cells(7, "A")

とすれば、マクロの有るBookの"Sheet1"に出力されます

>それから
>FileListには65000件程度のファイル名の記録が可能ということになりますでしょうか?

確かに、シートの行数は、65536行で、2行目から書き込んでいますので
65535件のファイル名を記録できますが?、此れでは、フォルダの管理も出来ませんし
ただ単に、読み込みファイルを決定するだけで時間が食われ実用的では無いと思いますよ?
FileListシートに書き込まれるファイル名の意味は、前回マクロ起動時に指定フォルダに有る
該当処理ファイルのリストです
其処で、今回マクロが起動した時点で、指定フォルダに有る該当処理ファイルのリストが、
新規に作成され、FileListシートのリストと比較されます、そして新規のリストに有り、
FileListシートのリストに無いファイルを処理ファイルとして処理します
そして、新規のリストをFileListシートのリストと置き換え終了します
因って、FileListシートのリストに有り、新規のリストに無いファイル名は、削除されたものとして
当然、新規のリストから抜け落ちます(結果として、削除されます)

ただ、前で書いた様に余りファイル数が多い場合は、実用的で無いと思いますので
一定期間等でファイルを削除若しくは、移動してフォルダを管理するべきだと思います
(フォルダを人間の目で見て管理出来るのは、せいぜい1000件以下では?)

【28751】Re:外部ファイルの自動読み込みについて
質問  ミツコ  - 05/9/13(火) 22:42 -

引用なし
パスワード
   Hirofumi さん ありがとうございます。

教えていただいたマクロでうまく動作しました。
ありがとうございます。

今、エクセル表の修正に挑戦していますが、そうすると
うまく動作しない為、何卒マクロの添削をお願いいたします。

前回はX軸に日付、Y軸にNoを外部CSVから取り込んでいました。
これを下記に記載しました様にX軸をNo、Y軸を日付に変更しdetaを取り込もうと思います。


CSVファイル(C:\system)
20050901,1001,0,0,1,003,1800
20050901,1003,0,0,1,001,1850
20050901,1005,0,0,1,005,1780


エクセルフォーマット(シート1)改定前
  A  B  C  D  E ・・・M    N  ・・・



7 No  名称 区分 分類 ・・・・日付読込 日付読込 ・・・
8 001              deta読込 deta読込 ・・・ 
9 002              deta読込 deta読込 ・・・ 
10 003              deta読込 deta読込 ・・・ 


改定後
  A    B    C    D   E・・・
1 No   001    002   003   004・・・
2日付読込 deta読込 deta読込 deta読込 deta読込
3日付読込 deta読込 deta読込 deta読込 deta読込
4日付読込 deta読込 deta読込 deta読込 deta読込
5日付読込 deta読込 deta読込 deta読込 deta読込
6 ・
7 ・


マクロは後半に続きます

【28753】Re:外部ファイルの自動読み込みについて
質問  ミツコ  - 05/9/13(火) 22:48 -

引用なし
パスワード
    Option Explicit


Public Sub CrossTabulation()

  '日付の先頭位置の前の列
  Const clngTop As Long = 0
  
  'ファイル名Listの有るシート名
  Const cstrList As String = "FileList"

  Dim i 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

  'ファイル名Listの有るシートの確認
  FileListCheck cstrList, wksFiles

  '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][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 = ThisWorkbook.Worksheets("Sheet1").Cells(1, "A")

  With rngResult
    '日付の書かれている行数を取得
    lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
    '日付列の範囲を取得
    If lngRow > 0 Then
      Set rngDate = .Offset(clngTop + 1).Resize(lngRow)
    End If
    'No.が有る列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
            - .Offset(, clngTop).Column
    'No.が有る範囲を取得
    If lngCol > 0 Then
      Set rngScope = .Offset(, 1).Resize(lngCol)
    End If
  End With

  For i = 1 To UBound(vntFileNames)
    '指定されたファイルをOpen
    dfn = FreeFile
    Open vntFileNames(i) For Input As dfn
    'ファイルから日付を取得
    Do Until EOF(dfn)
      'ファイルから1行読み込み
      Line Input #dfn, strBuff
      'フィールドに分割
      vntField = Split(strBuff, ",", , vbBinaryCompare)
      '「20050731」形式の日付をシリアル値に変換
      vntField(0) = CLng(DateValue(Left(vntField(0), 4) _
                & "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)))
      '日付を探索
      lngRow = GetDateColumn(vntField(0), rngDate, _
                rngResult.Offset(, clngTop)) + clngTop
      'No.を探索
      lngCol = GetTagNoRow(vntField(5), rngScope, rngResult)
      '日付、Noの交差するセルに値を書き込み
      With rngResult.Offset(lngRow, lngCol)
        .NumberFormatLocal = "G/標準"
        .Value = vntField(6)
      End With
    Loop
    Close #dfn
  Next i

Wayout:

  Application.ScreenUpdating = True

  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing
  Set wksFiles = Nothing

  Beep

End Sub
Private Function GetDateColumn(vntDate As Variant, _
                rngScope As Range, _
                rngDateTop As Range) As Long

  Dim lngFound As Long
  Dim lngOver As Long
  Dim lngCount As Long
 
  '日付範囲に日付が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
    lngOver = 1
  Else
    '日付の探索
    'セル値が数値として入力されている場合
    lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
    'セル値が文字列として入力されている場合
'    lngFound = DataSearch(vntDate, rngScope, lngOver)
    lngCount = rngScope.Columns.Count
  End If
 
  '日付が見つかった場合
  If lngFound > 0 Then
    '位置を返す
    GetDaterowlngFound
  Else
    With rngDateTop
      '日付が最終列の以内の場合
      If lngOver <= lngCount Then
        '指定位置に列を挿入
        .Offset(lngOver).EntireColumn.Insert
      End If
      '日付を書き込み
      With .Offset(lngOver)
        .NumberFormatLocal = "m/d"
        .Value = vntDate
      End With
      '挿入位置を返す
      GetDateColumn = lngOver
      '日付行の範囲を更新
      Set rngScope _
        = .Offset(1).Resize(lngCount + 1)
    End With
  End If
 
End Function

Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Long
  Dim lngCount As Long

  'No範囲にNoが無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
  Else
    'Noを探索
    lngFound = DataSearch(vntTagNo, rngScope, , 0)
    lngCount = rngScope.Rows.Count
  End If

  '探索成功(Noが有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetTagNoRow = lngFound
  Else
    With rngListTop
      '行末位置を更新
      lngCount = lngCount + 1
       'セルの書式を文字列に設定
      '(001の様な場合無いと探索が出来ない)
      .Offset(lngCount).NumberFormatLocal = "@"
      '行末にNoを書き込み
      .Offset(lngCount).Value = vntTagNo
      '挿入位置を返す
      GetTagNoRow = lngCount
      '探索範囲の更新
      Set rngScope _
        = .Offset(1).Resize(lngCount)
    End With
  End If

End Function

Private Function DataSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long, _
            Optional lngMode As Long = 1) As Long

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, lngMode)
  lngOver = 1
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      DataSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  End If

End Function


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
     If lngRows = 1 Then
        ReDim vntData(1 To lngRows, 1 To 2)
        vntData(lngRows, 1) = .Resize(lngRows).Value
      Else
        vntData = .Resize(lngRows).Value
        ReDim Preserve vntData(1 To lngRows, 1 To 2)
      End If

    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
    End If
    If j > 0 Then
      .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


省略

【28796】Re:外部ファイルの自動読み込みについて
回答  Hirofumi  - 05/9/14(水) 21:35 -

引用なし
パスワード
   全文をUpする意味が無いので
変更したプロシージャのみをUpします

Option Explicit

Public Sub CrossTabulation()

  '日付の先頭位置の前の列
  'Noの先頭位置の前の列 '★変更
  Const clngTop As Long = 0
 
  'ファイル名Listの有るシート名
  Const cstrList As String = "FileList"

  Dim i 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

  'ファイル名Listの有るシートの確認
  FileListCheck cstrList, wksFiles

  'Textファイルの有るフォルダを指定
  strPath = "C:\system"
'  strPath = "E:\Office2000\Excel\Test5\A"

  '読み込むファイルを取得(ダイアログを出さないで、指定フォルダから取得の場合)
  If Not GetAppendFile(vntFileNames, strPath, "txt", _
      "^[0-9][0-9][0-9][0-9][0-9][0-9]da*$|^[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 = ThisWorkbook.Worksheets("Sheet1").Cells(1, "A")

  With rngResult
    '日付の書かれている行数を取得
    lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
    '日付列の範囲を取得
    If lngRow > 0 Then
'      Set rngDate = .Offset(clngTop + 1).Resize(lngRow)
      Set rngDate = .Offset(1).Resize(lngRow) '★変更
    End If
    'No.が有る列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
            - .Offset(, clngTop).Column
    'No.が有る範囲を取得
    If lngCol > 0 Then
'      Set rngScope = .Offset(, 1).Resize(lngCol)
      Set rngScope = .Offset(, clngTop + 1).Resize(lngCol) '★変更
    End If
  End With

  For i = 1 To UBound(vntFileNames)
    '指定されたファイルをOpen
    dfn = FreeFile
    Open vntFileNames(i) For Input As dfn
    'ファイルから日付を取得
    Do Until EOF(dfn)
      'ファイルから1行読み込み
      Line Input #dfn, strBuff
      'フィールドに分割
      vntField = Split(strBuff, ",", , vbBinaryCompare)
      '「20050731」形式の日付をシリアル値に変換
      vntField(0) = CLng(DateValue(Left(vntField(0), 4) _
                & "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)))
      '日付を探索
      lngRow = GetDateColumn(vntField(0), rngDate, _
                rngResult.Offset(, clngTop)) + clngTop
      'No.を探索
      lngCol = GetTagNoRow(vntField(5), rngScope, rngResult)
      '日付、Noの交差するセルに値を書き込み
      With rngResult.Offset(lngRow, lngCol)
        .NumberFormatLocal = "G/標準"
        .Value = vntField(6)
      End With
    Loop
    Close #dfn
  Next i

Wayout:

  Application.ScreenUpdating = True

  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing
  Set wksFiles = Nothing

  Beep

End Sub

Private Function GetDateColumn(vntDate As Variant, _
                rngScope As Range, _
                rngDateTop As Range) As Long

  Dim lngFound As Long
  Dim lngOver As Long
  Dim lngCount As Long

  '日付範囲に日付が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
    lngOver = 1
  Else
    '日付の探索
    'セル値が数値として入力されている場合
    lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
    'セル値が文字列として入力されている場合
'    lngFound = DataSearch(vntDate, rngScope, lngOver)
'    lngCount = rngScope.Columns.Count
    lngCount = rngScope.Rows.Count '★変更
  End If

  '日付が見つかった場合
  If lngFound > 0 Then
    '位置を返す
'    GetDaterowlngFound
    GetDateColumn = lngFound '★変更
  Else
    With rngDateTop
      '日付が最終列の以内の場合
      If lngOver <= lngCount Then
        '指定位置に列を挿入
'        .Offset(lngOver).EntireColumn.Insert
        .Offset(lngOver).EntireRow.Insert '★変更
      End If
      '日付を書き込み
      With .Offset(lngOver)
        .NumberFormatLocal = "m/d"
        .Value = vntDate
      End With
      '挿入位置を返す
      GetDateColumn = lngOver
      '日付行の範囲を更新
      Set rngScope _
        = .Offset(1).Resize(lngCount + 1)
    End With
  End If

End Function

Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Long
  Dim lngCount As Long

  'No範囲にNoが無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
  Else
    'Noを探索
    lngFound = DataSearch(vntTagNo, rngScope, , 0)
'    lngCount = rngScope.Rows.Count
    lngCount = rngScope.Columns.Count '★変更
  End If

  '探索成功(Noが有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetTagNoRow = lngFound
  Else
    With rngListTop
      '行末位置を更新
      lngCount = lngCount + 1
       'セルの書式を文字列に設定
      '(001の様な場合無いと探索が出来ない)
'      .Offset(lngCount).NumberFormatLocal = "@"
      .Offset(, lngCount).NumberFormatLocal = "@" '★変更
      '行末にNoを書き込み
'      .Offset(lngCount).Value = vntTagNo
      .Offset(, lngCount).Value = vntTagNo '★変更
      '挿入位置を返す
      GetTagNoRow = lngCount
      '探索範囲の更新
'      Set rngScope _
        = .Offset(1).Resize(lngCount)
      Set rngScope _
        = .Offset(, 1).Resize(, lngCount) '★変更
    End With
  End If

End Function

【32249】Hirofumiさん教えてください。
質問  ミツコ  - 05/12/11(日) 11:15 -

引用なし
パスワード
   Hirofumi さんに前に教えていただいたCSV取り込みマクロですが
試行錯誤しながら工夫をしようとしています。

CSVにある日付、Noとsheet1にある日付、Noをリンクさせ数値を挿入しています。

現状ではCSVに記載ある"No"がsheet1に存在しない場合、最終行にNoの追加書き込みにしています。
これを止めて、csvに記載のNoがsheet1にある時のみ数値の挿入をする。
に変更したいのです。

下記の部分でいろいろ試していますが出来ません。
アドバイスをお願いします。


Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Variant
  Dim lngCount As Long

  'No範囲にNoが無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
  Else
    'Noを探索
    lngFound = DataSearch(CLng(vntTagNo), rngScope, , 0)
    lngCount = rngScope.Rows.Count
  End If

  '探索成功(Noが有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetTagNoRow = lngFound
  'Else
    'With rngListTop
      '行末位置を更新
      'lngCount = lngCount + 1
       'セルの書式を文字列に設定
      '(無いと探索が出来ない)
      '.Offset(lngCount).NumberFormatLocal = "@"
      '行末にNoを書き込み
      '.Offset(lngCount).Value = vntTagNo
      '挿入位置を返す
      'GetTagNoRow = lngCount
      '探索範囲の更新
      'Set rngScope _
        = .Offset(1).Resize(lngCount)
    'End With
  End If
End Function

【32250】現在利用しているコードも記載します1.
質問  ミツコ  - 05/12/11(日) 11:27 -

引用なし
パスワード
   現状のものを記載します。

Option Explicit
Public Sub CrossTabulation()
  '日付の先頭位置の前の列
  Const clngTop As Long = 10
  'ファイル名Listの有るシート名
  Const cstrList As String = "FileList"

  Dim i 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

  'ファイル名Listの有るシートの確認
  FileListCheck cstrList, wksFiles

  '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][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 = ThisWorkbook.Worksheets("sheet1").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)
    '指定されたファイルをOpen
    dfn = FreeFile
    Open vntFileNames(i) For Input As dfn
    'ファイルから日付を取得
    Do Until EOF(dfn)
      'ファイルから1行読み込み
      Line Input #dfn, strBuff
      'フィールドに分割
      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
      'No.を探索
      lngRow = GetTagNoRow(vntField(5), rngScope, rngResult)
      '日付、Noの交差するセルに値を書き込み
      With rngResult.Offset(lngRow, lngCol)
        .NumberFormatLocal = "G/標準"
        .Value = vntField(6)
      End With
    Loop
    Close #dfn
  Next i

Wayout:

  Application.ScreenUpdating = True

  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing
  Set wksFiles = Nothing

  Beep

End Sub
Private Function GetDateColumn(vntDate As Variant, _
                rngScope As Range, _
                rngDateTop As Range) As Long

  Dim lngFound As Long
  Dim lngOver As Long
  Dim lngCount As Long
 
  '日付範囲に日付が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
    lngOver = 1
  Else
    '日付の探索
    'セル値が数値として入力されている場合
    lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
    'セル値が文字列として入力されている場合
'    lngFound = DataSearch(vntDate, rngScope, lngOver)
    lngCount = rngScope.Columns.Count
  End If
 
  '日付が見つかった場合
  If lngFound > 0 Then
    '位置を返す
    GetDateColumn = lngFound
  Else
    With rngDateTop
      '日付が最終列の以内の場合
      If lngOver <= lngCount Then
        '指定位置に列を挿入
        .Offset(, lngOver).EntireColumn.Insert
      End If
      '日付を書き込み
      With .Offset(, lngOver)
        .NumberFormatLocal = "m/d"
        .Value = vntDate
      End With
      '挿入位置を返す
      GetDateColumn = lngOver
      '日付列の範囲を更新
      Set rngScope _
        = .Offset(, 1).Resize(, lngCount + 1)
    End With
  End If
 
End Function

Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Variant
  Dim lngCount As Long

  'No範囲にNoが無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
  Else
    'Noを探索
    lngFound = DataSearch(CLng(vntTagNo), rngScope, , 0)
    lngCount = rngScope.Rows.Count
  End If

  '探索成功(Noが有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetTagNoRow = lngFound
  'Else
    'With rngListTop
      '行末位置を更新
      'lngCount = lngCount + 1
       'セルの書式を文字列に設定
      '(無いと探索が出来ない)
      '.Offset(lngCount).NumberFormatLocal = "@"
      '行末にNoを書き込み
      '.Offset(lngCount).Value = vntTagNo
      '挿入位置を返す
      'GetTagNoRow = lngCount
      '探索範囲の更新
      'Set rngScope _
        = .Offset(1).Resize(lngCount)
    'End With
  End If
End Function

Private Function DataSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long, _
            Optional lngMode As Long = 1) As Long

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, lngMode)
  lngOver = 1
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      DataSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  End If

End Function


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

【32251】現在利用しているコードも記載します2.
質問  ミツコ  - 05/12/11(日) 11:28 -

引用なし
パスワード
   続きです。

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
     If lngRows = 1 Then
        ReDim vntData(1 To lngRows, 1 To 2)
        vntData(lngRows, 1) = .Resize(lngRows).Value
      Else
        vntData = .Resize(lngRows).Value
        ReDim Preserve vntData(1 To lngRows, 1 To 2)
      End If

    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
    End If
    If j > 0 Then
      .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

【32252】Re:現在利用しているコードも記載します2.
回答  Hirofumi  - 05/12/11(日) 13:00 -

引用なし
パスワード
   もうTestデータも削除してしまっているのでTest出来ませんが
以下を変更すれば善いと思います

1、「Public Sub CrossTabulation」の中で以下の様に変更


'      '日付を探索
'      lngCol = GetDateColumn(vntField(0), rngDate, _
'                rngResult.Offset(, clngTop)) + clngTop
'      'No.を探索
'      lngRow = GetTagNoRow(vntField(5), rngScope, rngResult)
'      '日付、Noの交差するセルに値を書き込み
'      With rngResult.Offset(lngRow, lngCol)
'        .NumberFormatLocal = "G/標準"
'        .Value = vntField(6)
'      End With
'    Loop

    〜

      'No.を探索
      lngRow = GetTagNoRow(vntField(5), rngScope, rngResult)
      '行位置が見つかったら
      If lngRow > 0 Then
        '日付を探索
        lngCol = GetDateColumn(vntField(0), rngDate, _
                  rngResult.Offset(, clngTop)) + clngTop
        '日付、Noの交差するセルに値を書き込み
        With rngResult.Offset(lngRow, lngCol)
          .NumberFormatLocal = "G/標準"
          .Value = vntField(6)
        End With
      End If
    Loop

2、「Private Function GetTagNoRow」を以下の様に変更

'★プロシージャ変更
Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Variant

  'No範囲にNoが無いなら
  If rngScope Is Nothing Then
    lngFound = 0
  Else
    'Noを探索
    lngFound = DataSearch(CLng(vntTagNo), rngScope, , 0)
  End If

  '位置を返す
  GetTagNoRow = lngFound

End Function

PS:
全文のUpは、全文のUpが如何しても必要な場合だけにした方が善いですよ

【32273】Re:現在利用しているコードも記載します2.
お礼  ミツコ  - 05/12/12(月) 1:56 -

引用なし
パスワード
   Hirofumi さん ありがとうございました。
動作は良好です。
感謝いたします。


また、ご指摘ありがとうございました。
> 全文のUpは、全文のUpが如何しても必要な場合だけにした方が善いですよ

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