No.3ベストアンサー
- 回答日時:
こんにちは。
補足の内容を拝見いたしました。
> そこでインデックスファイルを作成して、
> そこに受注番号、機種名、数量 等を自動入力させて
> 目次の様なファイルを作りたいと言う事です。
> 更に、ハイパーリンクを組み込み、クリック一発で
> 過去の受注ファイルを開く事が出来る様にしたいのです。
下記のコードは、関係企業から
「部品ごとに分けられたファイルのリストを作りたい」
との相談を受けて電話でのやりとりで作成したコードです。
質問者さんが意図した内容の処理に似てると思いましたので
コメントを読みながら処理の参考にしてみてください。
なお、私は現物のファイルも見ていませんし、現場にも出ていませんが、
ちゃんと目的の処理が実行されていると報告を受けています。
頭の中では、処理の内容が整理されていると思いましたので、
処理の手順を書き出して、その手順に従ってコードを組めば
意図した内容の処理ができると思います。
頑張ってください。
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
No.2
- 回答日時:
であればこんな感じ?
INDEXファイルを Index.xls と仮定し、記入するのはIndex.xlsのSheet(1)のA列に順に記載してゆくものと決め打ちにしています。
また、Index.xlsとデータファイルは同じフォルダ内にあるものと仮定しています。
フォルダが違う場合には、ThisWorkbook.Path を利用している部分を修正する必要があります。
Function Registは、bName(=登録しようとするファイル名)が既にあるかをチェックし、新規登録を行った場合はTrue、既に登録済で何もしなかった場合はFalseを返します。
(常に新規登録しか起こり得ないのであれば、登録済みかをチェックする必要もありませんので、かなり処理をはぶくことが可能です。)
Function Regist(bName As String) As Boolean
Dim wb As Workbook, c As Range
Dim rw As Long, bPath As String
Const index = "Index.xls" '// INDEXファイルのファイル名
Application.ScreenUpdating = False '// 必要に応じて表示をOFF
bPath = ThisWorkbook.Path & "\"
Set wb = Workbooks.Open(bPath & index)
wb.Worksheets(1).Activate
rw = Cells(Rows.Count, 1).End(xlUp).Row
Set c = Nothing
If (rw = 1) And (Cells(1, 1) = "") Then '//1行目も未記入(新規シート)
rw = 0
Else
'// 同じブック名が既にあるかをチェック
Set c = Range("A1:A" & rw).Find(bName, LookIn:=xlValues, LookAt:=xlWhole)
End If
If c Is Nothing Then '// リンクを登録
ActiveSheet.Hyperlinks.Add Anchor:=Cells(rw + 1, 1), _
Address:=bPath & bName, TextToDisplay:=bName
Regist = True
Else
Regist = False
End If
Application.DisplayAlerts = False '// 保存時の確認メッセージを回避
wb.Close (Regist)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
No.1
- 回答日時:
>ブック間で変数のやり取りは出来ないと思います。
できるんですか??変数のやり取りというより、データの記入でよいのですよね?できますよ。
具体的に何をやりたいのか、いまひとつよくわかりませんので、以下、簡単なサンプル。
新しいブックを作成して、そのブックのシート1のA1に、自分のブック名を書き込むというものです。
セルやレンジを指定するときには、きちんと識別できるように
Workbook.WorkSheet.Range の形で指定してあげる必要があります。
Sub test()
Dim filename As String
Dim wb As Workbook
filename = ThisWorkbook.Name
Set wb = Workbooks.Add
wb.Sheets(1).Cells(1, 1).Value = filename
End Sub
テキストファイルの読み書きも当然できますが、↑でもお望みのことができるのではないでしょうか?
この回答への補足
> ありがとうございました。
でも、私の説明の仕方が少し、良くなかった様なので再度説明します。
私は製造業の課長ですが、我々の生産は受注生産で
多くの機種が受注番号を付けられ、我々のところに来て
生産が行われます。
製造課に於いては、1つの受注オーダーに於いて、1つのエクセルファイルを作ります。
その中に生産時の情報が記録として、入力されます。(1オーダー、1ファイル))
そのファイルのセルA1には、受注番号を入力しますので
A1の受注番号を利用して、そのファイル自身に名前を付けて保存します。
ここまでは自分でマクロ組みました。
この様にしていくと、1ヶ月にかなりの数のファイルが出来ます。
(受注の数だけ出来る事になる。)
そこでインデックスファイルを作成して、
そこに受注番号、機種名、数量 等を自動入力させて
目次の様なファイルを作りたいと言う事です。
更に、ハイパーリンクを組み込み、クリック一発で
過去の受注ファイルを開く事が出来る様にしたいのです。
(ちなみに過去の受注ファイルは、生産終了後、たびたび使用する為)
製品によっては、日をまたいで生産する製品もあるし、
又、半分だけ生産して、一週間後に再開する製品もあります。
その為、受注ファイルが名前を付けて保存する時に
同時にINDEXファイルにも登録したいのです。
そうすれば、翌日、または一週間後にも、INDEXファイルから
簡単に開く事が可能になるからです。
新規に作成した受注ファイルは、その度に名前が変わる事になる為
名前を付けて保存する際にファイル名を変数に代入しました。
その後、自動でINDEXファイルを開き、OPENイベントで
変数を指定のセルに入力しようとしたんですが、だめでした。
ちなみ、上記のコード、今からチャレンジしてみます。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) エクセルのマクロについて教えてください。 1 2023/08/08 11:02
- Excel(エクセル) エクセルのマクロについて教えてください。 1 2023/02/03 13:18
- Excel(エクセル) エクセルのマクロについて教えてください。 1 2023/02/21 09:28
- その他(プログラミング・Web制作) pythonでクラスで複数のメソッドを利用する方法 2 2022/04/15 04:17
- Visual Basic(VBA) Excelのマクロコードについて教えてください。 1 2022/03/27 13:25
- Excel(エクセル) 【VBA】指定フォルダに格納中のテキストファイルをエクセルで処理し結果のエクセルを新規フォルダに保存 1 2022/03/25 14:19
- Excel(エクセル) エクセルのマクロについて教えてください。 2 2023/02/21 13:29
- Visual Basic(VBA) EXCEL VBA 単語置き換え について質問です ブック名 ぶぶぶ シート名 ししし セル V3〜 3 2023/03/08 01:41
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/07/16 14:36
- Excel(エクセル) エクセルのマクロについて教えてください。 1 2023/02/20 10:00
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルVBAが途中で止まります
-
VBA シートをコピーする際に Co...
-
別ブックをダイアログボックス...
-
VBAで別ブックのシートを指定し...
-
ワイルドカード「*」を使うとう...
-
VBS Bookを閉じるコード
-
VBAで複数のブックを開かずに処...
-
エクセルのマクロについて教え...
-
VBA コードを実行すると画面が...
-
ADOで複数のBookから抽出
-
ExcelVBA:すでに開かれている...
-
複数のエクセルブックをひとつ...
-
VBA 実行時エラー 2147024893
-
ExcelのVBAです。フォルダ内の...
-
Excelファイルを開くとき、読み...
-
Excelブックがアクティブになっ...
-
vbaで他のブックに転記したい。...
-
【ExcelVBA】zip圧縮されたCSV...
-
エクセルのマクロについて教え...
-
Excelマクロ 該当する値の行番...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
VBA シートをコピーする際に Co...
-
エクセルVBAが途中で止まります
-
別ブックをダイアログボックス...
-
【ExcelVBA】インデックスが有...
-
ワイルドカード「*」を使うとう...
-
【ExcelVBA】VBA実行でダイアロ...
-
ExcelのVBAです。フォルダ内の...
-
フォルダ内の全てのファイルに...
-
VBA コードを実行すると画面が...
-
VBA 別ブックからコピペしたい...
-
VBAで別ブックのシートを指定し...
-
VBS Bookを閉じるコード
-
vbaでvbaProjectのパスワード解...
-
【VBA】全シートの計算式を全て...
-
VBA シート名が一致した場合の...
-
【ExcelVBA】zip圧縮されたCSV...
-
複数のエクセルブックをひとつ...
-
VBSでExcelのオープン確認
-
VBAで別のブックにシートをコピ...
-
【Excel VBA】書き込み先ブック...
おすすめ情報