Excel VBA質問箱 IV

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

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


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

【27171】日付列を取得し、CSVデータを挿入について mimi 05/8/1(月) 1:28 質問[未読]
【27174】Re:日付列を取得し、CSVデータを挿入につ... だるま 05/8/1(月) 8:16 回答[未読]
【27178】Re:日付列を取得し、CSVデータを挿入につ... mimi 05/8/1(月) 10:15 発言[未読]
【27193】Re:日付列を取得し、CSVデータを挿入につ... だるま 05/8/1(月) 15:03 発言[未読]
【27196】Re:日付列を取得し、CSVデータを挿入につ... だるま 05/8/1(月) 15:23 回答[未読]
【27182】CSVデータの構造について m2m10 05/8/1(月) 11:34 お礼[未読]
【27187】Re:CSVデータの構造について mimi 05/8/1(月) 12:49 発言[未読]
【27195】Re:日付列を取得し、CSVデータを挿入につい... m2m10 05/8/1(月) 15:21 回答[未読]
【27205】Re:日付列を取得し、CSVデータを挿入につい... m2m10 05/8/1(月) 17:35 回答[未読]
【27209】Re:日付列を取得し、CSVデータを挿入につい... mimi 05/8/1(月) 22:12 質問[未読]
【27214】日付を探索 をする際に m2m10 05/8/2(火) 7:57 回答[未読]
【27264】Re:日付列を取得し、CSVデータを挿入につい... Hirofumi 05/8/3(水) 21:11 回答[未読]
【27266】Re:日付列を取得し、CSVデータを挿入につい... Hirofumi 05/8/3(水) 21:46 回答[未読]
【27268】Re:日付列を取得し、CSVデータを挿入につい... Hirofumi 05/8/3(水) 23:10 回答[未読]
【27307】Re:日付列を取得し、CSVデータを挿入につい... mimi 05/8/4(木) 19:30 質問[未読]
【27308】Re:日付列を取得し、CSVデータを挿入につい... Hirofumi 05/8/4(木) 20:10 回答[未読]
【27309】Re:日付列を取得し、CSVデータを挿入につい... Hirofumi 05/8/4(木) 20:13 回答[未読]
【27310】コードを整理して見ました Hirofumi 05/8/4(木) 21:40 回答[未読]
【27341】Re:コードを整理して見ました mimi 05/8/5(金) 19:57 質問[未読]
【27346】Re:コードを整理して見ました Hirofumi 05/8/5(金) 22:36 回答[未読]
【27348】Re:コードを整理して見ました mimi 05/8/5(金) 23:17 質問[未読]
【27349】Re:コードを整理して見ました Hirofumi 05/8/5(金) 23:57 回答[未読]
【27351】Re:コードを整理して見ました mimi 05/8/6(土) 1:29 お礼[未読]
【27352】Re:コードを整理して見ました Hirofumi 05/8/6(土) 5:59 発言[未読]
【27353】書き忘れた事がもう1点有りました Hirofumi 05/8/6(土) 7:40 発言[未読]
【27354】Re:書き忘れた事がもう1点有りました mimi 05/8/6(土) 12:37 質問[未読]
【27369】変更したコード Hirofumi 05/8/6(土) 16:35 回答[未読]
【27370】Re:変更したコード mimi 05/8/6(土) 19:02 お礼[未読]

【27171】日付列を取得し、CSVデータを挿入について
質問  mimi  - 05/8/1(月) 1:28 -

引用なし
パスワード
   CSVファイルをエクセルに取り込むマクロを作っています。
問題点は
CSVファイルの日付は文字列
エクセル側の日付はdate関数 です。
これらは変更できません。

どのようにすればエクセル表の日付列取得を行えるでしょうか?

CSVファイル
20050731 T1 135
20050731 T3 38
20050731 S1 40
20050731 T2 100
20050731 S2 70
20050731 U1 30
20050731 T5 5
20050731 T4 12


エクセル表
  A   B  C   D  E  F  G  H ・・・・
1商品名 単価 数量 7/30 7/31 8/1 8/2 8/3
2 S1        32  40
3 S2           70
4 T1        101 135
5 T2        95  100
6 T3           38
7 T4        10  12
8 T5           5
9 U1        25  30

【27174】Re:日付列を取得し、CSVデータを挿入につ...
回答  だるま WEB  - 05/8/1(月) 8:16 -

引用なし
パスワード
   Findで検索してはいかがでしょうか。^d^

Sub test()
  Const D As String = "20050802"
  Dim myDate As Date
  Dim myCell As Range
  
  myDate = DateSerial(Left$(D, 4), Mid$(D, 5, 2), Right$(D, 2))
  
  Set myCell = Rows(1).Find(what:=myDate, LookIn:=xlFormulas, lookat:=xlWhole)
  If Not myCell Is Nothing Then
    MsgBox myCell.Column
  Else
    MsgBox "Not Found"
  End If
  
End Sub

【27178】Re:日付列を取得し、CSVデータを挿入につ...
発言  mimi  - 05/8/1(月) 10:15 -

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


下記は定数ということでしょうか?
Const D As String = "20050802"

毎日行うCSVかかの自動挿入は困難と思いますが
何かよい方法は無いでしょうか

【27182】CSVデータの構造について
お礼  m2m10  - 05/8/1(月) 11:34 -

引用なし
パスワード
   CSV ファイルは↓みたいに、スペースで区切られていますか?

>CSVファイル
>20050731 T1 135
>20050731 T3 38
>20050731 S1 40
>20050731 T2 100
>20050731 S2 70
>20050731 U1 30
>20050731 T5 5
>20050731 T4 12

【27187】Re:CSVデータの構造について
発言  mimi  - 05/8/1(月) 12:49 -

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

記載はカンマでした。
申し訳ありません。

20050731,T1,135
20050731,T3,38
20050731,S1,40
20050731,T2,100
20050731,S2,70

【27193】Re:日付列を取得し、CSVデータを挿入につ...
発言  だるま WEB  - 05/8/1(月) 15:03 -

引用なし
パスワード
   >どのようにすればエクセル表の日付列取得を行えるでしょうか?

に対する回答のつもりでしたので、簡単な「例」を書いたまでです。
(でも要点は捕らえているつもりでしたが。)

CSVの読み込みとかセルへの書き込みはお分かりになるのかと思いましたが
勘違いでしたか。

全部作ってということであれば、すぐには無理です。
気が向けば作るかもしれませんが、その前に多分親切な方が作ってくれることでしょう。
^d^

【27195】Re:日付列を取得し、CSVデータを挿入につ...
回答  m2m10  - 05/8/1(月) 15:21 -

引用なし
パスワード
   例ですが

  dt02 = Split( , ",") で別けて

  位置を 2005,7,30を基準で 計算をし。 入れる。
 
  列 = 4 + DateSerial(Left$(dt02(0), 4), Mid$(dt02(0), 5, 2), _
     Right$(dt02(0), 2)) - DateSerial(2005, 7, 30)

   Cells(行, 列).Value = dt02(2)

【27196】Re:日付列を取得し、CSVデータを挿入につ...
回答  だるま WEB  - 05/8/1(月) 15:23 -

引用なし
パスワード
   >エクセル側の日付はdate関数 です。

「日付形式」だと勘違いしていました。
=Date(年,月,日)でしょうか。
でしたら、コード訂正です。^d^

Sub test()
  Const D As String = "20050802"
  Dim myDate As String
  Dim myCell As Range
 
  myDate = Format(DateSerial(Left$(D, 4), Mid$(D, 5, 2), Right$(D, 2)), "m/d")
 
  Set myCell = Rows(1).Find(what:=myDate, LookIn:=xlValues, lookat:=xlWhole)
  If Not myCell Is Nothing Then
    MsgBox myCell.Column
  Else
    MsgBox "Not Found"
  End If
 
End Sub

【27205】Re:日付列を取得し、CSVデータを挿入につ...
回答  m2m10  - 05/8/1(月) 17:35 -

引用なし
パスワード
   こんなの?

Sub Get_Csv_ファイル指定()
 Dim A_Path As String
 Dim 行 As Long
 Dim 列 As Long
 Dim FName
 Dim dt01 As String
 Dim dt02
 Dim i As Long

' Sheets("実績").Select
 
 FName = Application.GetOpenFilename("(*.CSV;*.TXT),*.CSV;*.txt")
 If FName = False Then Exit Sub
  Open FName For Input As #1

 行 = Range("A65536").End(xlUp).Offset(1).Row

 Do Until EOF(1)
 
  Line Input #1, dt01
   dt02 = Split(dt01, ",")
   Cells(行, "A").Value = dt02(1)
  
   列 = 4 + DateSerial(Left$(dt02(0), 4), Mid$(dt02(0), 5, 2), _
     Right$(dt02(0), 2)) - DateSerial(2005, 7, 30)
   Cells(行, 列).Value = dt02(2)
  
  
   Cells(行, 列).Value = dt02(2)
  
  行 = 行 + 1
 Loop
 
Close #1

End Sub

【27209】Re:日付列を取得し、CSVデータを挿入につ...
質問  mimi  - 05/8/1(月) 22:12 -

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

応用に苦労しています。
アドバイスを参考にして思いついたのですが

'日付を探索 をする際に 
CSVファルの日付からシリアル値を得て
エクセル側の日付を探索、挿入するのが簡単そうなのですが
如何でしょうか

恐らくだるま さんは同様の事をアドバイスしてくれていると思うのですが
"D"の部分の数式が分からず応用がでていません。


実際下記マクロを使用しています。


Public Sub 商品()

  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 blnWayOut As Boolean
 
  '「ファイルを開く」ダイアログを表示
Dim fileToOpen As Variant

ChDrive ""
ChDir ""
fileToOpen = Application.GetOpenFilename("テキスト ファイル (*.txt), *.txt")


  Application.ScreenUpdating = False
 
  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(3, "A")
  With rngResult
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
    '日付の有る範囲を取得
     If lngCol = 0 Then
      blnWayOut = True
      GoTo WayOut
    End If
    '日付列の範囲を取得
    Set rngDate = .Offset(, 1).Resize(, lngCol)
    'No.が有る範囲を取得
    Set rngScope = Range(.Offset(1), .Offset(65536 - .Row).End(xlUp))
  End With
 
 
  '指定されたファイルをOpen
  dfn = FreeFile
  Open fileToOpen For Input As dfn

  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '日付を探索
    lngCol = GetDateColumn(vntField(0), rngDate, rngResult)
    'No.を探索
    lngRow = GetTagNoRow(vntField(2), rngScope, rngResult)
    '日付、TagNoの交差するセルに値を書き込み
    rngResult.Offset(lngRow, lngCol).Value = vntField(3)
  Loop
 
  Close #dfn
 
WayOut:
 
  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing
 
  Application.ScreenUpdating = True
 
End Sub

【27214】日付を探索 をする際に
回答  m2m10  - 05/8/2(火) 7:57 -

引用なし
パスワード
   こんちは

  日付が順番に並んでいるなら、

  差し引きで可能です。

【27264】Re:日付列を取得し、CSVデータを挿入につ...
回答  Hirofumi  - 05/8/3(水) 21:11 -

引用なし
パスワード
   ワークシート側の日付が、シリアル値で入っていて、
Csv側が「20050731」形式の文字列で、ワークシートの日付を探す
マクロは、「Public Sub 商品()」を使うと言うなら以下を追加して下さい

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=20699;id=excel

    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '日付を探索
    vntField(0) = DateValue(Left(vntField(0), 4) & _
                "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)) '★この行追加
    lngCol = GetDateColumn(vntField(0), rngDate, rngResult)
    'No.を探索

日付をシリアル値に直しています
尚、ここには出てきていませんが、
「Function DataSearch」と「Function GetDateColumn」言う関数が有る筈です
「Function DataSearch」の中で、Matchワークシート関数で位置を探していますので
Matchで、日付(Date型)は探せ無いので、Long値で探す為
「Function GetDateColumn」では、

  'セル値が数値として入力されている場合
  lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
  'セル値が文字列として入力されている場合
'  lngFound = DataSearch(vntDate, rngScope, lngOver)

の「セル値が数値として入力されている場合」の方を使って下さい

【27266】Re:日付列を取得し、CSVデータを挿入につ...
回答  Hirofumi  - 05/8/3(水) 21:46 -

引用なし
パスワード
   尚、

エクセル表
  A   B  C   D  E  F  G  H ・・・・
1商品名 単価 数量 7/30 7/31 8/1 8/2 8/3
2 S1        32  40
3 S2 70
4 T1        101 135
5 T2        95  100
6 T3 38
7 T4        10  12
8 T5 5
9 U1        25  30

と成って居るとすると、以下の部分も変更が必要かも?

「商品名」の位置がA1なので

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
'  Set rngResult = ActiveSheet.Cells(3, "A")
  Set rngResult = ActiveSheet.Cells(1, "A") '◎要変更?

日付がD列で始まるので(元の表は、B列なので1)

    '日付列の範囲を取得
'    Set rngDate = .Offset(, 1).Resize(, lngCol)
    Set rngDate = .Offset(, 3).Resize(, lngCol) '◎要変更?

【27268】Re:日付列を取得し、CSVデータを挿入につ...
回答  Hirofumi  - 05/8/3(水) 23:10 -

引用なし
パスワード
   結構、あっちこっち直さないと使え無い見たい?

Option Explicit

Public Sub 商品()

  '日付の先頭位置(A列からのOffset値)
  Const clngTop As Long = 3
  
  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 blnWayOut As Boolean

  '「ファイルを開く」ダイアログを表示
Dim fileToOpen As Variant

'ChDrive ""
'ChDir ""
fileToOpen = Application.GetOpenFilename("テキスト ファイル (*.txt), *.txt")


  Application.ScreenUpdating = False

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


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

  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '日付を探索
    vntField(0) = DateValue(Left(vntField(0), 4) & _
                "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)) '★この行追加
    lngCol = GetDateColumn(vntField(0), rngDate, rngResult)
    'No.を探索
    lngRow = GetTagNoRow(vntField(1), rngScope, rngResult) '◎要変更?
    '日付、TagNoの交差するセルに値を書き込み
    rngResult.Offset(lngRow, lngCol).Value = vntField(2) '◎要変更?
  Loop

  Close #dfn

WayOut:

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

  Application.ScreenUpdating = True
 
End Sub

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

  '日付の先頭位置(A列からのOffset値)
  Const clngTop As Long = 3
  
  Dim lngFound As Long
  Dim lngOver As Long

  'セル値が数値として入力されている場合
  lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
  'セル値が文字列として入力されている場合
'  lngFound = DataSearch(vntDate, rngScope, lngOver)
  '日付が見つかった場合
  If lngFound > 0 Then
    '位置を返す
    GetDateColumn = lngFound + clngTop - 1
  Else
    With rngListTop
      '日付が最終列の以内の場合
      If lngOver <= rngScope.Columns.Count Then
        '指定位置に列を挿入
        .Offset(, lngOver + clngTop - 1).EntireColumn.Insert
      End If
      '日付を書き込み
      .Offset(, lngOver + clngTop - 1).Value = vntDate
      '挿入位置を返す
      GetDateColumn = lngOver + clngTop - 1
      '日付列の範囲を更新
      Set rngScope _
        = .Offset(, clngTop).Resize(, rngScope.Columns.Count + 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 lngOver As Long

  lngFound = DataSearch(vntTagNo, rngScope, lngOver)
  If lngFound > 0 Then
    GetTagNoRow = lngFound
  Else
    With rngListTop.Offset(1)
      If lngOver <= rngScope.Rows.Count Then
        .Offset(lngOver).EntireRow.Insert
      End If
      .Offset(lngOver).Value = vntTagNo
      GetTagNoRow = lngOver
      Set rngScope _
        = .Offset(1).Resize(rngScope.Rows.Count + 1)
    End With
  End If

End Function

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

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, 1)
  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

【27307】Re:日付列を取得し、CSVデータを挿入につ...
質問  mimi  - 05/8/4(木) 19:30 -

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

下記のように書き換えました。

質問があるのですが
lngCol = GetDateColumn(vntField(0), rngDate, rngResult) にて

コンパイルエラーが起こります。
sub または Functionが定義されていません。
"GetDateColumn"
どういうことなのでしょうか?


Public Sub 商品()

  '日付の先頭位置(A列からのOffset値)
  Const clngTop As Long = 3
 
  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 blnWayOut As Boolean

  '「ファイルを開く」ダイアログを表示
Dim fileToOpen As Variant

ChDrive ""
ChDir ""
fileToOpen = Application.GetOpenFilename("")


  Application.ScreenUpdating = False

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


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

  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '日付を探索
    vntField(0) = DateValue(Left(vntField(0), 4) & _
                "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)) '★この行追加
    lngCol = GetDateColumn(vntField(0), rngDate, rngResult) '← GetDateColumn
    'No.を探索
    lngRow = GetTagNoRow(vntField(1), rngScope, rngResult) '◎要変更?
    '日付、TagNoの交差するセルに値を書き込み
    rngResult.Offset(lngRow, lngCol).Value = vntField(2) '◎要変更?
  Loop

  Close #dfn

WayOut:

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

  Application.ScreenUpdating = True

End Sub

【27308】Re:日付列を取得し、CSVデータを挿入につ...
回答  Hirofumi  - 05/8/4(木) 20:10 -

引用なし
パスワード
   >質問があるのですが
>lngCol = GetDateColumn(vntField(0), rngDate, rngResult) にて
>
>コンパイルエラーが起こります。
>sub または Functionが定義されていません。
>"GetDateColumn"
>どういうことなのでしょうか?

此れはですね、ここにUpされているコードだけでは完結されていないんです
このコードを動かすには、4つのプロシージャが必要なんです
まだ、気に入らない所が有るのですが、今のレスの上に付けたレス
 
【27268】Re:日付列を取得し、CSVデータを挿入について 
  Hirofumi - 05/8/3(水) 23:10 - 

に、全文をUpして有りますので、其れを全て同じ標準モジュールに記述(コピペ)
して試して下さい

【27309】Re:日付列を取得し、CSVデータを挿入につ...
回答  Hirofumi  - 05/8/4(木) 20:13 -

引用なし
パスワード
   後、基本的には変えない積もりですが
もう少し、コードを整理して見る積もりです

【27310】コードを整理して見ました
回答  Hirofumi  - 05/8/4(木) 21:40 -

引用なし
パスワード
   コードを整理して見ました
以下の5つのプロシージャで1Setですので
全て同じ標準モジュールに記述(コピペ)して下さい
尚、商品名が既に入っている場合、昇順に整列されていなければ成りません
もし、昇順に整列されて居ない場合、コードの変更が必要に成ります

Option Explicit

Public Sub 商品()

  '日付の先頭位置の前の列(「数量」の見だし位置のA列からのOffset値)
  Const clngTop As Long = 2
  
  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

  'Textファイルの有るフォルダを指定
  strPath = ThisWorkbook.Path
  '「ファイルを開く」ダイアログを表示
  If Not GetReadFile(vntFileName, strPath, False) Then
    strProm = "マクロがキャンセルされました"
    GoTo WayOut
  End If

  Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(1, "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) = 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(1), rngScope, rngResult)
    '日付、TagNoの交差するセルに値を書き込み
    With rngResult.Offset(lngRow, lngCol)
      .NumberFormatLocal = "G/標準"
      .Value = vntField(2)
    End With
  Loop

  Close #dfn
  
  strProm = "処理が完了しました"

WayOut:

  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 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).Value = vntTagNo
      '挿入位置を返す
      GetTagNoRow = lngOver
      '探索範囲の更新
      Set rngScope _
        = .Offset(1).Resize(lngCount + 1)
    End With
  End If

End Function

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

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, 1)
  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 = "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, 2, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

【27341】Re:コードを整理して見ました
質問  mimi  - 05/8/5(金) 19:57 -

引用なし
パスワード
   Hirofumi さん ありがとうございます。
とても感謝しています。
若干手を加えさせて頂きました。

どうしても下記の部分がデバッグで表示されます。
何が考えられるでしょうか

'セル値が数値として入力されている場合
lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)

何卒、ご教授お願いいたします。


Option Explicit

Public Sub 商品()

  '日付の先頭位置の前の列(「数量」の見だし位置のA列からのOffset値)
  Const clngTop As Long = 2
 
  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 fileToOpen As Variant
  'Textファイルの有るフォルダを指定
  strPath = ThisWorkbook.Path

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

  Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(1, "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) = 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) 'vntField(5)でOK
    '日付、TagNoの交差するセルに値を書き込み
    With rngResult.Offset(lngRow, lngCol)
      .NumberFormatLocal = "G/標準"
      .Value = vntField(6)    'vntField(6)でOK
    End With
  Loop

  Close #dfn
 
  strProm = "処理が完了しました"

WayOut:

  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 = DateSearch(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 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).Value = vntTagNo
      '挿入位置を返す
      GetTagNoRow = lngOver
      '探索範囲の更新
      Set rngScope _
        = .Offset(1).Resize(lngCount + 1)
    End With
  End If

End Function

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

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, 1)
  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
 
    ChDrive "C"            '修正しました
    ChDir "\Program Files\"
  'フィルタ文字列を作成
  strFilter = "テキスト ファイル (*.txt), *.txt"

  'もし、ディフォルトのファイル名が有る場合
  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

【27346】Re:コードを整理して見ました
回答  Hirofumi  - 05/8/5(金) 22:36 -

引用なし
パスワード
   >どうしても下記の部分がデバッグで表示されます。
>何が考えられるでしょうか
>
>'セル値が数値として入力されている場合
>lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)

Excel2003で検証し、此れの原因が解りました
当方、Excel97でこのコードを作成していますが
其れ以降のExcelのVar.で、Variant型配列の扱いが少し違う様です
以下を修正して下さい

現状のコード

    '「20050731」形式の日付をシリアル値に変換
    vntField(0) = DateValue(Left(vntField(0), 4) _
                & "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2))

修正後のコード

    '「20050731」形式の日付をシリアル値に変換
    vntField(0) = CLng(DateValue(Left(vntField(0), 4) _
                & "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)))

尚、mimiさんが、修正している以下の部分も修正方法が違うので
再修正して下さい(特に問題は無さそうですが?)

1、「Dim fileToOpen As Variant」使っていない変数を宣言する必要が無いのでこの行不要

2、以下のFunctionの修正は不要、汎用性が無くなるので元のままの方が善いと思います

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

  Dim strFilter As String

    ChDrive "C"            '修正しました
    ChDir "\Program Files\"
  'フィルタ文字列を作成
  strFilter = "テキスト ファイル (*.txt), *.txt"

  'もし、ディフォルトのファイル名が有る場合
  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

尚、この部分の修正方法が有りますので下に書いて置きます
以下を修正して下さい

  Dim strProm As String
'Dim fileToOpen As Variant '☆不要

  'Textファイルの有るフォルダを指定
'  strPath = ThisWorkbook.Path '★この行変更
  strPath = "C:\Program Files"

尚、ここに書きませんでしたが、

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

  'Defaultのファイル名を指定する場合
  vntFileName = "Test" '◎追加しても可

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

とすれば、「ファイルを開くダイアログ」の「ファイル名」Boxに「Test」と
表示され、"C:\Program Files"の中で、Testが頭に付くファイルだけ表示されます
ワイルドカードも使えると思います

【27348】Re:コードを整理して見ました
質問  mimi  - 05/8/5(金) 23:17 -

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

どうしても実行エラー75
パス名が無効です となります。

デバッグ
Open vntFileName For Input As dfn

原因が分かりますでしょうか?
またdfn の役割は何でしょうか?

申し訳ありません。


Option Explicit

Public Sub 商品()

  '日付の先頭位置の前の列(「数量」の見だし位置のA列からのOffset値)
  Const clngTop As Long = 2
 
  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

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

  Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(1, "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
    'No.を探索
    lngRow = GetTagNoRow(vntField(5), rngScope, rngResult) 'vntField(5)でOK
    '日付、TagNoの交差するセルに値を書き込み
    With rngResult.Offset(lngRow, lngCol)
      .NumberFormatLocal = "G/標準"
      .Value = vntField(6)    'vntField(6)でOK
    End With
  Loop

  Close #dfn
 
  strProm = "処理が完了しました"

WayOut:

  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 = DateSearch(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 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).Value = vntTagNo
      '挿入位置を返す
      GetTagNoRow = lngOver
      '探索範囲の更新
      Set rngScope _
        = .Offset(1).Resize(lngCount + 1)
    End With
  End If

End Function

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

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, 1)
  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 fileToOpen As Variant
  Dim strFilter As String

        ChDrive "C"
ChDir "\Program Files\KEYENCE\BT-500\DATA\"
fileToOpen = Application.GetOpenFilename("テキスト ファイル (*.txt), *.txt")
  
 
  GetReadFile = True
 
End Function

【27349】Re:コードを整理して見ました
回答  Hirofumi  - 05/8/5(金) 23:57 -

引用なし
パスワード
   >どうしても実行エラー75
>パス名が無効です となります。
>
>デバッグ
>Open vntFileName For Input As dfn
>
>原因が分かりますでしょうか?
>またdfn の役割は何でしょうか?
>
>申し訳ありません。

そりゃ、そうなるでしょ?
書き換えている「Function GetReadFile」が、出鱈目だもの
何故、言う通りに直さないの?
何か都合が悪いの?

「Sub 商品()」の中を次の様に変更して下さい

  'Textファイルの有るフォルダを指定
'  strPath = ThisWorkbook.Path '★変更
  strPath = "C:\Program Files\KEYENCE\BT-500\DATA"

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

「Function GetReadFile」を元に戻す

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

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "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, 2, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

尚、dfnは、ファイルバッファ番号で、ファイルをOpenした後は、この番号で
開いているファイルを認識します
ただ、今回のエラーは、此れじゃ無いよ
「Function GetReadFile」を書き換えた為、
vntFileName変数にファイル名(フルパスの)が返って着て無い為に起こっています
vntFileName変数の中は""が返っています

【27351】Re:コードを整理して見ました
お礼  mimi  - 05/8/6(土) 1:29 -

引用なし
パスワード
   Hirofumi さん

ほんとうにありがとうございました。

とても感謝しています。
そしてとても感動しています。

最後に質問ですがHirofumi さんはどのようにしてVBAを覚えられたのでしょうか
やはりPCスクールでしょうか?
お薦めの書籍があれば教えて頂けませんか

ありがとうございました。

【27352】Re:コードを整理して見ました
発言  Hirofumi  - 05/8/6(土) 5:59 -

引用なし
パスワード
   >最後に質問ですがHirofumi さんはどのようにしてVBAを覚えられたのでしょうか
>やはりPCスクールでしょうか?
>お薦めの書籍があれば教えて頂けませんか

書籍と独学だけです
ただ、こう言う物は、色々書いて、人の真似もして
エラーもいっぱい出して、悩まないと書けないような気がします
尚、私はVBA以前からなので、現在、何がお薦めの書籍なのか解りません

【27353】書き忘れた事がもう1点有りました
発言  Hirofumi  - 05/8/6(土) 7:40 -

引用なし
パスワード
    後、書き忘れた事がもう1点有りました
コードを善く見てもらえば解る事だと思いますが?

 現状、このコードの処理対象は、ActiveSheetにして有ります
此れは何を意味するかと言うと、このマクロが必ずしも、転記するBookに無くても動くと言う事です
詰まり、転記するBookが幾つも有る場合(月等によりBookが新しく成る様な場合)
そのBook毎に、このマクロを記述せずとも使えます

 その方法は、新規のBookの標準モジュールに、このマクロを記述して、
コンパイルし、適当な名前で保存して置きます
 転記したい時は、先ず適当な名前を付けたマクロの有るBookを起動します
次に、転記したいBookを開き、転記するSheetをActiveにします
ここで、このマクロを起動すれば、Activeにして有るSheetを対象に処理が成されます
処理終了後、転記したBookを保存終了し、マクロの有るBookを保存せず終了すれば、
転記するBookは、常にデータだけと成ります
マクロを修正した時も、マクロが一元化され修正、無修正のマクロが混在状態になる事も無くなります

尚、逆に、Book、Sheetを固定化させたい場合

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

のActiveSheetをBook名で修飾したSheetを指定します
例えば、常にマクロの有るBookのSheet1と言う名前のシートに転記する場合

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

とします
また、表を、1行下にしたい、1列右にしたい等と言う場合
.Cells(1, "A")の値を(1を2にすれば2行目、"A"を"B"にすればB列)変更して下さい

【27354】Re:書き忘れた事がもう1点有りました
質問  mimi  - 05/8/6(土) 12:37 -

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

あと2点ほど質問があるのですが
・日付が無い場合、自動入力されますがこれを止めてmsgbox"日付が見つかりません"にするには何処を変える必要があるでしょうか

・商品名が無い場合、昇順で行が追加されます。これを止めて最終行に追加するにはどのようにすれば良いでしょうか?


申し訳ありません。

【27369】変更したコード
回答  Hirofumi  - 05/8/6(土) 16:35 -

引用なし
パスワード
   >あと2点ほど質問があるのですが
>・日付が無い場合、自動入力されますがこれを止めてmsgbox"日付が見つかりません"にするには
>何処を変える必要があるでしょうか
>
>・商品名が無い場合、昇順で行が追加されます。これを止めて最終行に追加するには
>どのようにすれば良いでしょうか?

Option Explicit

Public Sub 商品1()

  '日付の先頭位置の前の列(「数量」の見だし位置のA列からのOffset値)
  Const clngTop As Long = 2

  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:\Program Files\KEYENCE\BT-500\DATA"

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

  Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(1, "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)))
    '日付を探索
    lngCol = GetDateColumn(vntField(0), rngDate, _
                rngResult.Offset(, clngTop)) + clngTop
    If lngCol = 0 + clngTop Then
      '該当日付が無い場合、メセージを出して継続する場合
'      With Application
'        If Not .ScreenUpdating Then
'          .ScreenUpdating = True
'        End If
'      End With
'      MsgBox Format(vntField(0), "m/d") & " の該当日付が有りません", _
'                    vbOKOnly + vbInformation, "NoMatch"
'      If strNoMatch <> "" Then
'        strNoMatch = strNoMatch & vbCrLf
'      End If
'      strNoMatch = strNoMatch & Format(vntField(0), "m/d") & " " & vntField(5)
      '該当日付が無い場合、メセージを出し直ちに終了する場合
      strProm = Format(vntField(0), "m/d") & " の日付が該当しませんので終了します"
      GoTo WayOut
    Else
      'No.を探索
      lngRow = GetTagNoRow(vntField(5), rngScope, rngResult) 'vntField(5)でOK
      '日付、TagNoの交差するセルに値を書き込み
      With rngResult.Offset(lngRow, lngCol)
        .NumberFormatLocal = "G/標準"
        .Value = vntField(6)    'vntField(6)でOK
      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

  '日付範囲に日付が無いなら
  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 Long
  Dim lngCount As Long

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

  '探索成功(商品名が有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetTagNoRow = lngFound
  Else
    With rngListTop
      '行末位置を更新
      lngCount = lngCount + 1
      '行末に商品名を書き込み
      .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 = "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, 2, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If

  GetReadFile = True

End Function

【27370】Re:変更したコード
お礼  mimi  - 05/8/6(土) 19:02 -

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

とても助かりました。

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