Excel VBA質問箱 IV

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

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


48493 / 76732 ←次へ | 前へ→

【33174】Re:外部ファイルの条件選択について
質問  みり  - 06/1/4(水) 16:20 -

引用なし
パスワード
   かみちゃん様、Hirofumi様 ありがとうございます。
動作確認をさせて頂きました。

過去の検索をし、Hirofumi様の外部データの取り込みマクロを
改造してみました。
ダイアログを表示させてファイルを選択すれば動作します。

これに今回ご提示頂いたマクロを組み込み、ダイアログによる選択を無くすには
どのようにすればよいかが分かりません。

ご指導をお願い致します。


Public Sub データ表示()

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

  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
  Dim A As String

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

  '「ファイルを開く」ダイアログを表示
  If Not GetReadFile(vntFileName, strPath, False) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする
  Set rngResult = Worksheets("フォーマット").Cells(8, "A")
  With rngResult
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
            - .Offset(, clngTop).Column
    '日付列の範囲を取得
    If lngCol > 0 Then
      Set rngDate = .Offset(, clngTop + 1).Resize(, lngCol)
    Else
      strProm = "日付列が有りません。"
      GoTo Wayout
    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)))

        'No.を探索
      lngRow = GetTagNoRow(vntField(4), rngScope, rngResult)
      '行位置が見つかったら
      If lngRow > 0 Then
        '日付を探索
        lngCol = GetDateColumn(vntField(0), rngDate, _
                  rngResult.Offset(, clngTop)) + clngTop
      If lngCol = 0 + clngTop Then
      '該当日付が無い場合、メセージを出し直ちに終了する
      strProm = Format(vntField(0), "m/d") & " の日付が有りません。"
      GoTo Wayout
      End If
        '日付、Noの交差するセルに値を書き込み
        With rngResult.Offset(lngRow, lngCol)
          .NumberFormatLocal = "G/標準"
          .Value = vntField(5)
        End With
        
        A = vntField(1)
        rngResult.Offset(2, lngCol).Value = Left(A, 2) & ":" & Right(A, 2)
        
      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

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

  GetDateColumn = lngFound

End Function

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

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
0 hits

【33137】外部ファイルの条件選択について みり 06/1/3(火) 15:59 質問
【33138】Re:外部ファイルの条件選択について かみちゃん 06/1/3(火) 16:07 発言
【33139】Re:外部ファイルの条件選択について かみちゃん 06/1/3(火) 16:23 回答
【33157】Re:外部ファイルの条件選択について Hirofumi 06/1/3(火) 19:52 回答
【33174】Re:外部ファイルの条件選択について みり 06/1/4(水) 16:20 質問
【33179】Re:外部ファイルの条件選択について Hirofumi 06/1/4(水) 17:32 回答
【33184】Re:外部ファイルの条件選択について みり 06/1/4(水) 18:24 質問
【33188】Re:外部ファイルの条件選択について Hirofumi 06/1/4(水) 18:44 発言
【33196】Re:外部ファイルの条件選択について Hirofumi 06/1/4(水) 20:38 回答
【33198】Re:外部ファイルの条件選択について Hirofumi 06/1/4(水) 20:45 発言
【33297】Re:外部ファイルの条件選択について みり 06/1/7(土) 19:00 質問
【33298】Re:外部ファイルの条件選択について Hirofumi 06/1/7(土) 21:52 回答

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