Excel VBA質問箱 IV

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

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


52811 / 76735 ←次へ | 前へ→

【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


省略
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 お礼

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