[[20040819143128]] 『目次を作りたいのですが』(辛汗) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『目次を作りたいのですが』(辛汗)

シートがたくさんあり、そのシート名を新シートに表記(目次)させたいのですが、なにか良い方法はありますでしょうか?
シート選びは出来るのですが、「印刷したい」というところで・・
普通にサクサクと目次を作れば良いのですが、ブックもたくさんありまして・・
宜しくお願いします。


 該当Bookの標準モジュールに入れて実行してみてください。

 Sub test1()
 '目次作成
 Dim ws As Worksheet
 Dim i As Integer
 ActiveWorkbook.Sheets.Add
 ActiveSheet.Name = "目次"
 i = 1
 For Each ws In ActiveWorkbook.Sheets
     Cells(i, 1).Value = ws.Name
     i = i + 1
 Next
 End Sub
 (川野鮎太郎)


一瞬で・・・感激です。
川野鮎太郎様ありがとうございました。(辛汗)


 横からすみません、教えてください。
 一度、目次を作成してから、シート名が増えて再度実行するとエラーになります。
 目次シートが既にある場合のコードは、どうしたらいいのでしょうか。
 (代奈)


 あいた〜wΣ(ノ∀`)ペチ。
 その目次シートを消す!ってのはだめですか(^_^A;
 または、シート名を変えてみるとか・・・
 (川野鮎太郎)

 そうですね、わかりました。
 では目次シートを手動で消してから実行します(^^) 
 シートを削除するコードとかメッセージボックスを出すコードとか
 一人であれこれ考えて分からなかったものですから。。。
 有難うございましたm(__)m
 (代奈)

 川野さんのコードをお借りして
Sub test1()

 Dim ws As Worksheet
 Dim i As Integer

 Application.DisplayAlerts = False

 On Error Resume Next

 Sheets("目次").Delete
 ActiveWorkbook.Sheets.Add before:=Worksheets(1)
 ActiveSheet.Name = "目次"

 i = 1
 For Each ws In ActiveWorkbook.Sheets
     Cells(i, 1).Value = ws.Name
     i = i + 1
 Next

 Application.DisplayAlerts = True

 End Sub
こんな感じでどうでしょう?
(ケン)

 ケンさんフォローありがとうございますm(_ _)m

 番号追加ってことで(^_^A;
 Sub test1()
 '目次作成
 Dim ws As Worksheet
 Dim i As Integer
 ActiveWorkbook.Sheets.Add
 If ActiveSheet.Name = "目次" Then

 ActiveSheet.Name = "目次"
 Else
 ActiveSheet.Name = "目次(1)"
 i = 1
 For Each ws In ActiveWorkbook.Sheets
    Cells(i, 1).Value = ws.Name
    i = i + 1
 Next
 End If
 End Sub

 じゃあ、目次(1)ってあった場合は? ってのは、無しの方向で_/ ̄|○ il||li
 (川野鮎太郎)

 ケンさんありがとうございました(^^)
 目次シートを削除して下さったのですね、うまくいきました!
 川野さん...すみません、目次がないのに「目次(1)」って表示されちゃいます...
 私のやり方が悪いのでしょうか?
 (代奈)

 (T▽T)アハハ!すいませんさっきの忘れてください。
 あわてたもので、よく見てませんでした_/ ̄|○ il||li
 (川野鮎太郎)

 あの...ごめんなさい。
 最近、川野さんの_/ ̄|○ il||liこのポーズをよく見かけます。
 下記でうまく行きました、すみませんでした。
 元気だして下さいね...

 Sub test1()
 '目次作成
 Dim ws As Worksheet
 Dim i As Integer
 ActiveWorkbook.Sheets.Add
 If ActiveSheet.Name = "目次" Then

 ActiveSheet.Name = "目次(1)"

 Else

 ActiveSheet.Name = "目次(1)"

 i = 1
 For Each ws In ActiveWorkbook.Sheets
    Cells(i, 1).Value = ws.Name
    i = i + 1
 Next

 End If
 End Sub

 あれ...おかしいな...うまくいかない...
 んんん。さっきはうまくいったのに
 (代奈@格闘中)

 VBAでない方法
一番左側のシートを「目次」という名前のシートとします。
「挿入」>「名前」>「定義」で下記の関数に名前を付けます。

名前
ShName
参照範囲
=IF(GET.WORKBOOK(4)>=ROW(),MID(INDEX(GET.WORKBOOK(1),ROW()),FIND("]",INDEX(GET.WORKBOOK(1),ROW()))+1,31)&T(NOW()),"")

 シートの一行目に
=ShName
と入力してこれをずりずりずりーっと下の行へコピー、貼付します。
多目でかまいません。
残念ながら、自動再計算にはならないので、シート追加した時には
F9キーを押すなどして再計算を実行してください。
(KAMIYA)

 す...すごいですね(>_<)
 参照範囲の式を理解するのも難しいくらいハイテク(裏テク?)レベルで...!
 でも、うまくいきました...どういう仕組みなのでしょう?
 奥が深すぎて光が見えないかも...です...
 その上、自動再計算になりました!
  (代奈)

 裏テク中の裏テク、4.0マクロ関数です。
Excelが非対応になるのも間近と思いますので、
将来のことを考えるとどうかとも思いますが・・・。
GET.WORKBOOK関数
ヘルプには載っていません。
とりあえず、使えそうな引数のみ抜粋。

1
ブックに含まれるシート名の一覧 (水平方向の文字列配列)。シート名は "[Book1]Sheet1" のような形式で返されます。
4
ブックに含まれるシートの数。
16
ブック名 (文字列)。戻り値には、ドライブ、フォルダ、およびウィンドウ番号は含まれません。
38
アクティブ シートの名前。
 (KAMIYA)

 一応作ってみました(*´ノェ`)コソーリ

 Sub test2()
 '目次作成
 Dim ws As Worksheet
 Dim i As Integer

 Application.DisplayAlerts = False
 For Each ws In ActiveWorkbook.Sheets
     If ws.Name = "目次" Then
        msg = MsgBox("目次シートが存在します!" & Chr(13) & Chr(13) & "シートを削除しますか?" & Chr(13) & "いいえの場合には目次(1)になります。", vbYesNo)
        If msg = vbYes Then
            Sheets("目次").Delete
     Else
        wsname = "目次(1)"
 Exit For
        End If
        wsname = "目次"
     End If
 Next
 ActiveWorkbook.Sheets.Add before:=Worksheets(1)
 ActiveSheet.Name = wsname
 i = 1
 For Each ws In ActiveWorkbook.Sheets 
     Cells(i, 1).Value = ws.Name
     i = i + 1
 Next
 Application.DisplayAlerts = True
 End Sub

 (川野鮎太郎)

 KAMIYAさん、どこでそんな技を...
 4.0マクロ関数?マクロと関数の合体形があるんですね、無知でした(>_<)
 調べてみることにします。

 川野さん...うう...な、なぜ...
 ActiveSheet.Name = wsname
 で実行時エラー1004が...(T_T)
 (代奈)

 !?工エエェ(゚〇゚ ;)ェエエ工!?
 ま・ま・まさか・・・
 目次(1)のシートがあるのに、いいえを選択したとか・・・_/ ̄|○ il||li
 (川野鮎太郎)

 >4.0マクロ関数?マクロと関数の合体形があるんですね、無知でした(>_<)
Excel5以前のマクロ言語です。知らなくて当然です。シート上では使えません。
以前のヴァージョンの互換性のためだけに残されている機能なので、
いつ非対応になってもおかしくありません。
Lotus花盛りの頃の機能なので、Web情報も多くありません。
個人的にはマクロでも難しい機能が実現できたりで重宝しているのですが。

 To 川野さん
Deleteにこだわりがあるようですが、
「目次」シートがなければ「目次」シートを追加、
あった場合は既存のデータをクリア、
データを再取得、という方法ではだめなの?
 Sub MOKUJI()
 Dim Ws As Worksheet
 Dim flag As Boolean
 Dim i As Long

     For Each Ws In Worksheets
         If Ws.Name = "目次" Then
             Ws.Range("A:A").ClearContents
             flag = True
             Exit For
         End If
     Next Ws

     If flag = False Then
         Set Ws = ThisWorkbook.Worksheets.Add(before:=Worksheets(1))
         Ws.Name = "目次"
     End If

     For i = 1 To Worksheets.Count
         Ws.Cells(i, 1).Value = Worksheets(i).Name
     Next i

 End Sub

 (KAMIYA)

 いえいえ、こだわりがあるというわけでは無いのですが、使う方の構成によって目次の目次が必要な場合もあるのかなと思い、
 残したいかどうかを判断できようようにした次第です(^_^A;
 (川野鮎太郎)

 エラートラップを使ったサンプルです。ご参考までに・・・。

 Sub Sample()
 Dim ws As Worksheet
 Dim i As Long
 Dim wsName As String: wsName = "目次"

 With ActiveWorkbook

    'シート追加
    Set ws = .Sheets.Add(before:=Worksheets(1))

    On Error GoTo ErrTrap
        ws.Name = wsName 'シート名の設定
    On Error GoTo 0

    'シート名取得
     For i = 1 To .Sheets.Count
         ws.Cells(i + 1, 1).Value = .Sheets(i).Name
     Next

        ws.Range("A1").Value = "シート名"
        ws.Columns(1).AutoFit
        MsgBox wsName & "シートを作成しました", , "目次作成"

    Exit Sub 'マクロ終了
 '================================-

 ErrTrap: '重複シート処理

    If vbYes = MsgBox(wsName & "シートは既にあります。削除して作り直してもいいですか?" _
               , vbYesNo + vbQuestion) Then
         Application.DisplayAlerts = False
             .Sheets(wsName).Delete 'シート削除
         Application.DisplayAlerts = True
    Else
        i = i + 1
        wsName = "目次_" & i 'シート名に連番付与
    End If

    Resume

 End With
 End Sub

   (INA)

 INAさん、さすがです。(_ _ ;)尸"マイリマシタ・・・

 いくつ目次が増えても良いようになってるんですね。。。

 エラーとラップですか・・・_〆\(..;) メモメモ

 エラーが怒ったら、ラップでなだめるんですね。。。           (失礼(^_^A;)

 というか、またもやスレ主さんと関係ないところで長いレスをしてしまいました(^_^A;

 (川野鮎太郎)

 KAMIYAさん、エレガントな作品有難うございました。
 関数、マクロ、書式etc.全般に通じておられ、驚くばかりです。
 INAさん、見事としか言いようのない作品、有難うございました。 
 使用者の立場になり、細部まで心配りされており、素晴らしいと思いました。
 川野さん、VBAって、楽しいですね!(川野さんも(*^^*))
 このサイトを拝見するようになってから、VBAに興味を持ちました。
 ご提示頂きました貴重なコード、一つ一つを紐解いて身になるようにしたいと思います。
 有難うございました
 (代奈)


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.