| |
>これに今回ご提示頂いたマクロを組み込み､ダイアログによる選択を無くすには
>どのようにすればよいかが分かりません｡
>
>ご指導をお願い致します｡
1、まず、みりさんが、「- 06/1/4(水) 16:20 -」にUpされたコードと同じ標準モジュールに、
「Private Function GetFilesList」をCopyします
2、ダイアログ表示はし無いので「Private Function GetReadFile」は削除します
3、以下のプロシージャは、其のまま使います
「Function GetDateColumn」
「Function GetTagNoRow」
「Function DataSearch」
4、以下の様にコードを変更します
尚、データが無いのでTestはしておりませんので宜しく
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
Dim i As Long '◎追加
Dim vntDate As Variant '◎追加
'Textファイルの有るフォルダを指定
strPath = "C:\list"
'★以下の5行削除
' '「ファイルを開く」ダイアログを表示
' 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
'抽出日付を取得(B3のセル位置) ◎追加
vntDate = .Offset(-5, 1).Value '◎追加
'日付の書かれている列数を取得
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
'フォルダから指定日付のファイル名を取得 ◎追加
If Not GetFilesList(vntFileName, strPath, vntDate) Then '◎追加
strProm = "指定日付のファイルが有りません" '◎追加
GoTo Wayout '◎追加
End If '◎追加
'取得したファイル名分繰り返し ◎追加
For i = 1 To UBound(vntFileName) '◎追加
'指定されたファイルをOpen
dfn = FreeFile
Open vntFileName(i) For Input As dfn '☆変更
'ファイルEndまで繰り返し
Do Until EOF(dfn)
'ファイルから１行読み込み
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") & " の日付が有りません。"
Close #dfn '◎追加
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)
Else '◎追加
'該当Itemが無い場合、メセージを出し直ちに終了する ◎追加
strProm = vntField(4) & " のItemが有りません。" '◎追加
Close #dfn '◎追加
GoTo Wayout '◎追加
End If
Loop
Close #dfn '◎追加
Next i '◎追加
'★以下の5行削除
' If strNoMatch = "" Then
' strProm = "処理が完了しました"
' Else
' strProm = "以下の該当しない日付がファイルに存在します" & vbCrLf & strNoMatch
' End If
strProm = "処理が完了しました" '◎追加
Wayout:
' Close #dfn '★削除
Application.ScreenUpdating = True
Set rngScope = Nothing
Set rngDate = Nothing
Set rngResult = Nothing
' Beep '★削除
MsgBox strProm, vbInformation '☆変更
End Sub
|
|
Hirofumi
- 06/1/4(水) 17:32 -
