こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

セルの値をシート名にするエクセルVBA

件名のVBAを以下のように書きました
B列の4からずっと下までのセルの値を次々とシート「ひな型」をコピーし増やしていくものです。

Sub テスト()
'
' Macro
'

'
Dim target As Range
Dim h As Range

'見えてるセルを取得する。「全部隠れていた」場合も考える。
On Error Resume Next
Set target = Worksheets("Sheet1").Range("B4:B" & Worksheets("Sheet1").Range("B65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
If target Is Nothing Then Exit Sub

'シートを増やしていく
For Each h In target
On Error GoTo errhandle
Worksheets(CStr(h.Value)).Select
On Error GoTo 0
Next
Sheets("Sheet1").Select

Exit Sub

errhandle:
Worksheets("ひな型").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = h.Value
Resume
End Sub


これだと、一応思った通りにはなるのですが
B列のセルに複数同じ名前があった時に、既に作ったシートの名前がある場合
それは無視するという風に実行したいです

お知恵をお貸しくださいませ

投稿日時 - 2015-07-02 17:02:33

QNo.9004788

困ってます

質問者が選んだベストアンサー

 例えば下記の様なVBAのマクロは如何でしょうか。

Sub Sample()

Dim target As Range, h As Range, mySheetName(1, 1) As String, _
mySheet(2) As Worksheet, DataColumn As String, FirstRow As Long, _
LastRow As Long, i As Byte, buf As String, myBoolean As Boolean

mySheetName(0, 0) = "ひな型" '作成するシートのひな型となるシートのシート名
mySheetName(0, 1) = "テンプレートである" 'mySheetName(0, 0)と同名のシートが存在しなかった場合に表示する文面の一部
mySheetName(1, 0) = "Sheet1" '作成するシートのシート名のデータが入力されているシートのシート名
mySheetName(1, 1) = "シート名のデータが入力されている" 'mySheetName(1, 0)と同名のシートが存在しなかった場合に表示する文面の一部
DataColumn = "B" '作成するシートのシート名のデータが入力されている列の列番号
FirstRow = 4 '作成するシートのシート名のデータが入力されている最初の行の行番号

'現在開いているシートを取得
Set mySheet(2) = ActiveSheet

'このVBAで使用する事を想定しているシートが実際に存在しているか否かを確認
For i = 0 To 1
If IsError(Evaluate("ROW('" & mySheetName(i, 0) & "'!A1)")) Then
MsgBox "新たに作成するシートの" & mySheetName(i, 1) _
& vbCrLf & vbCrLf & mySheetName(i, 0) & vbCrLf & vbCrLf _
& "というシート名のシートが見つかりません。" & vbCrLf & _
"マクロの実行を中止します。", vbExclamation, "存在しないシート"
Exit Sub
Else
Set mySheet(i) = Sheets(mySheetName(i, 0))
End If
Next i

'見えているセルの中で最も下にあるセルの行番号を取得
'及び、作成するシートのシート名のデータの有無を確認
LastRow = mySheet(1).Range(DataColumn & Rows.Count).End(xlUp).Row
If LastRow < FirstRow Then
MsgBox "新たに作成するシートに設定するためのシート名のデータが有りません。" _
& vbCrLf & "マクロの実行を中止します。", vbExclamation, "データ無し"
Exit Sub
End If

'見えているセルを取得する。「全部隠れていた」場合も考える。
Set target = mySheet(1).Range(DataColumn & FirstRow & ":B" _
& DataColumn & LastRow).SpecialCells(xlCellTypeVisible)

'モニター表示の更新停止
Application.ScreenUpdating = False

'セル範囲targetに含まれている各セルごとに繰り返し処理
For Each h In target

'セルhの値がシート名として使用可能な文字列であるか否かを判定
myBoolean = Not IsError(h)
If myBoolean Then
buf = h.Value & ""
If buf = "" Then
myBoolean = False
Else
For i = 1 To 7
If InStr(buf, Mid(":\/?*[]", i, 1)) > 0 Then myBoolean = False
Next i
End If
End If

'セルhの値がシート名として使用可能な文字列で、
'尚且つ既存のシートに同名のシートが無い場合に限り、
'セルhの値と同名のmySheet(0)シートのコピーシートを作成
If myBoolean Then
If IsError(Evaluate("ROW('" & buf & "'!A1)")) Then
mySheet(0).Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = buf
End If
End If

Next h

'元のシートを選択
mySheet(2).Select

'モニター表示の更新再開
Application.ScreenUpdating = True

End Sub

投稿日時 - 2015-07-03 06:34:06

お礼

ありがとうございました!
しっかりとそれぞれを確認し、勉強させて頂きます!

投稿日時 - 2015-07-03 11:21:16

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.3

或いは


Sub Sample2()

Dim target As Range, h As Range, mySheetName(1, 1) As String, _
mySheet(2) As Worksheet, DataColumn As String, FirstRow As Long, _
LastRow As Long, i As Byte, buf As String, myBoolean As Boolean

mySheetName(0, 0) = "ひな型" '作成するシートのひな型となるシートのシート名
mySheetName(0, 1) = "テンプレートである" 'mySheetName(0, 0)と同名のシートが存在しなかった場合に表示する文面の一部
mySheetName(1, 0) = "Sheet1" '作成するシートのシート名のデータが入力されているシートのシート名
mySheetName(1, 1) = "シート名のデータが入力されている" 'mySheetName(1, 0)と同名のシートが存在しなかった場合に表示する文面の一部
DataColumn = "B" '作成するシートのシート名のデータが入力されている列の列番号
FirstRow = 4 '作成するシートのシート名のデータが入力されている最初の行の行番号

'現在開いているシートを取得
Set mySheet(2) = ActiveSheet

'このVBAで使用する事を想定しているシートが実際に存在しているか否かを確認
For i = 0 To 1
If IsError(Evaluate("ROW('" & mySheetName(i, 0) & "'!A1)")) Then
MsgBox "新たに作成するシートの" & mySheetName(i, 1) _
& vbCrLf & vbCrLf & mySheetName(i, 0) & vbCrLf & vbCrLf _
& "というシート名のシートが見つかりません。" & vbCrLf & _
"マクロの実行を中止します。", vbExclamation, "存在しないシート"
Exit Sub
Else
Set mySheet(i) = Sheets(mySheetName(i, 0))
End If
Next i

'見えているセルの中で最も下にあるセルの行番号を取得
'及び、作成するシートのシート名のデータの有無を確認
LastRow = mySheet(1).Range(DataColumn & Rows.Count).End(xlUp).Row
If LastRow < FirstRow Then
MsgBox "新たに作成するシートに設定するためのシート名のデータが有りません。" _
& vbCrLf & "マクロの実行を中止します。", vbExclamation, "データ無し"
Exit Sub
End If

'見えているセルを取得する。「全部隠れていた」場合も考える。
Set target = mySheet(1).Range(DataColumn & FirstRow & ":B" _
& DataColumn & LastRow).SpecialCells(xlCellTypeVisible)

'モニター表示の更新停止
Application.ScreenUpdating = False

'mySheet(0)シートのコピーシートを1枚作成
mySheet(0).Copy after:=Sheets(Sheets.Count)

'セル範囲targetに含まれている各セルごとに繰り返し処理
For Each h In target
If h.Value <> "" And Not IsError(h) Then
Application.DisplayAlerts = False
On Error Resume Next
Sheets(Sheets.Count).Name = h.Value & ""
On Error GoTo 0
Application.DisplayAlerts = True
If Sheets(Sheets.Count).Name = h.Value & "" Then _
mySheet(0).Copy after:=Sheets(Sheets.Count)
End If
Next h

'不要になった最後のmySheet(0)シートのコピーシートを削除
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True

'元のシートを選択
mySheet(2).Select

'モニター表示の更新再開
Application.ScreenUpdating = True

End Sub

投稿日時 - 2015-07-03 06:41:00

ANo.1

> B列のセルに複数同じ名前があった時に、既に作ったシートの名前がある場合
> それは無視するという風に実行したいです

今もそのような作りになっていますが、現在のコードではどんな時に問題が有るのでしょう?
B列の名前にシート名に使用できない文字が有るとエラーになりますが……。

投稿日時 - 2015-07-02 17:33:50

あなたにオススメの質問