VBA でテキストファイルに読み書き

質問

エクセル2000のVBAを使用しています。
ブックAファイル名をブックBのセルに入力して、ブックAをインデックスの様な扱いのファイルを作成使用としたのですが、ブック間で変数のやり取りは出来ないと思います。できるんですか？？
　その為、txtファイルを変数代わりに使おうと思っているのですが、
入出力の方法が良くわかりません。
　簡単にブックBのセルの値をtxtファイルに書き込んでブックAで、
そのtxtファイルを読み込む様なVBAのコード教えて下さい。
初心者ですけど・・。

回答No.3

OtenkiAme · ベストアンサー

こんにちは。

補足の内容を拝見いたしました。

> そこでインデックスファイルを作成して、
> そこに受注番号、機種名、数量　等を自動入力させて
> 目次の様なファイルを作りたいと言う事です。
> 更に、ハイパーリンクを組み込み、クリック一発で
> 過去の受注ファイルを開く事が出来る様にしたいのです。
下記のコードは、関係企業から
「部品ごとに分けられたファイルのリストを作りたい」
との相談を受けて電話でのやりとりで作成したコードです。

質問者さんが意図した内容の処理に似てると思いましたので
コメントを読みながら処理の参考にしてみてください。

なお、私は現物のファイルも見ていませんし、現場にも出ていませんが、
ちゃんと目的の処理が実行されていると報告を受けています。

頭の中では、処理の内容が整理されていると思いましたので、
処理の手順を書き出して、その手順に従ってコードを組めば
意図した内容の処理ができると思います。
頑張ってください。

Sub Sample()

Dim OldSheetsCount As Long

Dim OpenFile As Variant, myBookName As String, _
　　myPath As String, myFile As String, myFileName As String, _
　　NewBook As Workbook, ListSht As Worksheet, _
　　OpenBook As Workbook, OpenSht As Worksheet, _
　　Target As Range, i As Long

'読み込むフォルダを指定する
OpenFile = Application.GetOpenFilename( _
　　FileFilter:="エクセル ファイル (*.xls), *.xls", _
　　Title:="部品コードのブックを一つ選択して［開く］をクリックしてください。", _
　　MultiSelect:=False)

'キャンセルされたら終了
If OpenFile = False Then MsgBox "処理を中止します。": Exit Sub

'画面更新を止める
Application.ScreenUpdating = False

'キャンセルされなかったら処理を継続
'新規シートを一枚にセットして新規ブックを作る
With Application
　　OldSheetsCount = .SheetsInNewWorkbook
　　.SheetsInNewWorkbook = 1
　　Set NewBook = .Workbooks.Add
　　.SheetsInNewWorkbook = OldSheetsCount
End With

'記録用ワークシート
Set ListSht = NewBook.Worksheets(1)

'項目名の記入
With ListSht.Range("A1:C1")
　　.Value = Array("部品コード", "型式名", "登録ブック名")
　　.Interior.ColorIndex = 6
　　.HorizontalAlignment = xlCenter
End With

'ウィンドウ枠の固定
Application.GoTo Reference:=ListSht.Range("A2")
ActiveWindow.FreezePanes = True

'このブック名
myBookName = ThisWorkbook.Name

'ドライブとパスの変更
myPath = Left(OpenFile, Len(OpenFile) - InStr(1, StrReverse(OpenFile), "\"))
ChDrive myPath
ChDir myPath

'Dir関数によりフォルダ内のすべてのブックに対して繰り返し
myFile = Dir("*.xls")
Do While myFile <> ""

　　'自ブックでない時
　　If myFile <> myBookName Then

　　　　'読み取り専用で開く
　　　　Set OpenBook = Workbooks.Open(Filename:=myFile, ReadOnly:=True)

　　　　'開いたブックの最初のシート
　　　　Set OpenSht = OpenBook.Worksheets(1)

　　　　With ListSht

　　　　　　'シートから"型式名"を探す
　　　　　　On Error Resume Next
　　　　　　Set Target = OpenSht.Cells.Find(What:="型式名", _
　　　　　　　　After:=OpenSht.Range("A1"), LookIn:=xlFormulas, _
　　　　　　　　LookAt:=xlPart, SearchOrder:=xlByRows)
　　　　　　On Error GoTo 0

　　　　　　'"型式名"があったら
　　　　　　If Not Target Is Nothing Then

　　　　　　　　'カウンタリセット
　　　　　　　　i = 1
　　　　　　　　Do

　　　　　　　　　　'すべての型式名を取得してシートに書き込む
　　　　　　　　　　With .Range("B" & .Rows.Count).End(xlUp).Offset(1)
　　　　　　　　　　　　.NumberFormat = "@"
　　　　　　　　　　　　.Value = Target.Offset(i).Value
　　　　　　　　　　End With

　　　　　　　　　　'ハイパーリンクを設定する
　　　　　　　　　　.Hyperlinks.Add _
　　　　　　　　　　　　Anchor:=.Range("C" & .Rows.Count).End(xlUp).Offset(1), _
　　　　　　　　　　　　Address:=OpenBook.FullName, TextToDisplay:=OpenBook.Name

　　　　　　　　　　'カウンタ加算
　　　　　　　　　　i = i + 1

　　　　　　　　Loop Until Target.Offset(i).Value = ""

　　　　　　　　'ブック名を部品コードとしてシートに書き込む
　　　　　　　　With .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(i - 1)
　　　　　　　　　　.NumberFormat = "@"
　　　　　　　　　　.Value = Replace(myFile, ".xls", "")
　　　　　　　　End With

　　　　　　End If
　　　　End With

　　　　'開いたブックを閉じる
　　　　OpenBook.Close Savechanges:=False
　　　　Set OpenSht = Nothing
　　　　Set OpenBook = Nothing

　　End If

　　'次のブック
　　myFile = Dir()

Loop
'↑ここまで繰り返し

'アクティブセル領域に対し、列幅自動調整、部品コード順に並べ替え
With ListSht.Range("A1").CurrentRegion

　　.EntireColumn.AutoFit
　　.Sort Key1:=.Parent.Parent.Parent.Range("A2"), Order1:=xlAscending, _
　　　　Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
　　　　Orientation:=xlTopToBottom, SortMethod:=xlPinYin

　　'もし書き込みデータがなかったらブックを閉じる
　　If .Cells.Count = 3 Then
　　　　Application.DisplayAlerts = False
　　　　NewBook.Close Savechanges:=False
　　　　Application.DisplayAlerts = True
　　End If

End With

'シート名を現在の日付& 時刻にする
ListSht.Name = Format(Now, "yyyy年mm月dd日hh時mm分ss秒")

'画面更新を有効
Application.ScreenUpdating = True

Set ListSht = Nothing
Set NewBook = Nothing

End Sub

お礼

有り難うございました。
非常に参考になり、思った事が
実現しました。
本当に有り難うございました。