Excel シートを自動作成、セル値をシート名に

質問

エクセルのマクロの自動記録で作業の効率化を図りたいのですがうまく出来ません、ご教示いただけ無いでしょうか。
（VBAは初心者です。本とネットを検索しながら作成していたのですが、
急きょファイルを作成しなければいけない状況になりました。）

■Excel2010

■ブック詳細
・Sheet"企業一覧"　→　行ごとに企業名、シート名が記載された表があります。
　　A列　企業名
　　B列　シート名

・Sheet"マスタ"　→　見積書のフォーマットがあります。
　　A4　企業名　

■希望作業
シート「企業一覧」の企業ごとにボタンを作り、ボタンを押すと

1."マスタ（Sheet)"のコピーが作成され、
2.コピーされたシートのA4セルに"企業一覧（Sheet)"A列の企業名が記載され、
3.コピーされたシート名に"企業一覧（Sheet)"のB列のシート名が記載され、
4."企業一覧（Sheet)"のB列のシート名に新しいシートへのハイパーリンクを付け
5."企業一覧（Sheet)"に戻る

※下記作業ができません。
・コピーされた新しいシートに、シート名が付けられない。
・"企業一覧（Sheet)"のシート名にコピーされた新しいシートへのハイパーリンクを付けられない。

※シートのコピーは可能なら"企業一覧（Sheet)"の企業名表記順に作成したいと思っています。

※各企業行ごとにボタンを作るのは面倒なのですが、
企業名/シート名の表記がよく変更になるため、入力と同時にマクロが実行されるのではなく、
何かワンクッションを置きたいと思っています。

※シートのコピー作成、企業名の記載までは出来たのですが、
その他の作業ができません。よろしくお願いいたします。

---------------------------
Sub Sheet作成()
'
' Sheet作成 Macro
'
'
Sheets("マスタ").Select
Sheets("マスタ").Copy After:=Sheets("マスタ")
Range("A4:B4").Select
ActiveCell.FormulaR1C1 = "=企業一覧!R8C1"
Range("C4").Select

Exit Sub

End Sub

--------------------------

回答No.1

keithin · ベストアンサー

変更点：
１．マクロを取り付けるボタンは「１つだけ」用意する事として，「現在選ばれているセル」のシートを作成することにします
　　（複数セル選択可。不連続セルの選択可。マクロボタンは記号一覧シートに作成すること。）
２．選択されたデータの該当するシートが「既に作成済み」である場合は，既存の該当企業シートを「削除」し，新たに作成することにします
３．新しいシートの「どこへの」ハイパーリンクを付けたいのか不明なのでＡ４にする
４．リストＢ列の記載が「不適切なシート名」だった場合は無視して続行する

sub macro1()
　dim h as range
　application.screenupdating = false
　on error resume next

　for each h in application.intersect(selection.entirerow, range("A:A"))
　if h <> "" then

’既存シートを削除する
　application.displayalerts = false
　worksheets(h.offset(0, 1).value).delete
　application.displayalerts = true

’シートを作成する
　worksheets("マスタ").copy after:=worksheets(worksheets.count)
　activesheet.name = h.offset(0, 1).value
　range("A4").formula = "=企業一覧!" & h.address
　h.offset(0, 1).hyperlinks.delete
　worksheets("企業一覧").hyperlinks.add anchor:=h.offset(0, 1), address:="", subaddress:= h.offset(0, 1) & "!A4"

　end if
　next

’シートを並べ替える
　worksheets("企業一覧").select
　for each h in range("B2:B" & range("B65536").end(xlup).row)
　worksheets(h.value).move after:=worksheets(worksheets.count)
　next
　worksheets("企業一覧").select
　application.screenupdating = true
end sub

お礼

ありがとうございました。
初歩的な質問で恥ずかしい（申し訳ない）のですが、

1.「現在選ばれているセル」「不連続セルの選択可」とご記載頂いていますが、
セルは企業名のセルをCtrl+マウスの左クリックで選択してからボタンを押せばよいのでしょうか…？
　ネットで記載していただいたコードを調べながらやってみたのですがうまくいきません…。
　「Entire（全体の）＋Row（行）」

2.なお、ハイパーリンクは企業一覧のシート名が書かれたセルに
　新しく作成されたシートへのハイパーリンクを付けたいと思っています。
（企業一覧シートは「企業名、シート名」が記載され、
　ハイパーリンクで各シートに飛べる目次のようなイメージのシートにしたいと思っています）

回答No.4

tom04

こんばんは！
企業一覧SheetのA列セルをダブルクリックの操作ではどうでしょうか？

画面左下の「企業一覧」SheetのSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてA列（企業名）をダブルクリックしてみてください。
アップされている画像通り、「企業一覧」Sheetの企業データは
A8セル以降にあるとしています。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Columns(1)) Is Nothing Then Exit Sub
If Target.Row > 7 And Target <> "" Then
Cancel = True
Dim i, k As Long
Dim str As String
i = Target.Row
str = Cells(i, 2)
For k = 3 To Worksheets.Count
If Worksheets(k).Name = str Then
Worksheets(k).Cells(4, 1) = Cells(i, 1)
End If
Next k
Worksheets(2).Cells.Copy
Worksheets.Add after:=Worksheets(Worksheets.Count)
On Error GoTo 1
With ActiveSheet
.Cells(1, 1).Select
.Paste
.Name = Cells(i, 2)
.Cells(4, 1) = Cells(i, 1)
End With
ActiveSheet.Cells(1, 1).Select
Application.CutCopyMode = False
Exit Sub
1:
Application.DisplayAlerts = False
Worksheets(Worksheets.Count).Delete
Application.DisplayAlerts = True
Worksheets(str).Activate
ActiveSheet.Cells(1, 1).Select
Exit Sub
End If
End Sub

※　ご希望の方法でなかったらごめんなさいね。m(_ _)m

お礼

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

ほぼ希望の作業だったのですが、2件対応されていませんでした…。

・企業一覧のシート名に新しいシートへのリンクを付ける
・企業一覧のリスト順にシートを並び替える。

ただ、ダブルクリックで動作が行うことができるなど
考えもつかなかったので、次回利用させていただきたいと思います。

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

回答No.3

keithin

マクロの使い方から説明しなきゃダメですか。
何をしたら「どうダメだった」のか具体的な状況のご説明がありませんので，どこを間違っているともどうしたらいいとも，「回答したとおりにちゃんとやれば出来ますよ」としかアドバイスのしようがありません。

次の通りにもう一回やって下さい：
ALT+F11を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに，回答のマクロを漏れなくコピー貼り付ける

ファイルメニューから終了してエクセルに戻る
企業一覧のシートにオートシェイプの四角形を一個描画する
右クリックしてマクロの登録を行い，さっきコピーしたMacro1を登録する

８行目から１５行目までデータを正しく記入しておく。Ａ列に企業名，Ｂ列にシート名。
Ａ８，Ｂ９：Ｂ１０，Ｃ１２などをコントロールキーなどを押しながら飛び飛びで選択する
オートシェイプに取り付けたマクロをクリックして実行する。

お礼

ご連絡が遅くなり申し訳ありません。

出来ました!!　
感動して何度もボタンを押し、大量にSheetを作成してしましました。

先日はもともと作成してあったボタンに「Macro1」を登録していたのですが、
新規でオートシェイプから四角形を作成したらうまくいきました！　

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

回答No.2

mar00

Sheet"企業一覧のシート名のシートがまだ存在しない状態からマクロを実行する事を前提としています。
もし存在していればエラーになります。(エラーの処理はしていません。)
Sub Sheet作成()
Set WS01 = Worksheets("企業一覧")
For i = 1 To WS01.Cells(Rows.Count, 1).End(xlUp).Row
Sheets("マスタ").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Range("A4").FormulaR1C1 = "=企業一覧!R[" & i - 4 & "]C"
Sheets(Sheets.Count).Name = WS01.Range("B" & i)
WS01.Range("B" & i).Hyperlinks.Delete
WS01.Hyperlinks.Add anchor:=WS01.Range("B" & i), Address:="", SubAddress:= _
WS01.Range("B" & i) & "!A4"
Next i
WS01.Select
End Sub

お礼

ありがとうございます。

ただ、企業はたびたび追加・変更になるため、企業一覧のシートは存在する事を前提にしたいと思っております。