Excelのワークシートを名前を指定してマクロで自動生成

質問

ExcelでSheet1のA1からA20のセルに入力されている文字を
ワークシート名にした新しいワークシートを20枚、
マクロで自動生成したいです。

ご教授のほど、何卒よろしくお願いします。

回答No.5

marbin · ベストアンサー

別ブックで作成するサンプルです。
エラー処理(念のための二重エラー処理もあり)がいくつかありますので長ったらしくなっていますが・・・。

Option Explicit

Sub test()
Dim wba As Workbook
Dim wbb As Workbook
Dim wsa As Worksheet
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim newwsmei As String
Dim bl As Boolean
Dim newwscnt As Integer
Dim newwbmei As String
Set wba = ThisWorkbook
Set wsa = wba.Worksheets("Sheet1")
newwscnt = 20
If WorksheetFunction.CountA(wsa.Range(wsa.Cells(1, 1), wsa.Cells(newwscnt, 1))) <> newwscnt Then
AppActivate Application.Caption
MsgBox "新規シート名が入力されていないセルがあります。"
Exit Sub
End If
bl = True
For i = 1 To newwscnt
If WorksheetFunction.CountIf(wsa.Range(wsa.Cells(i, 1), wsa.Cells(newwscnt, 1)), wsa.Cells(i, 1)) <> 1 Then
bl = False
End If
Next i
If bl = False Then
AppActivate Application.Caption
MsgBox "新規ファイル名が重複しています。"
Exit Sub
End If
Application.ScreenUpdating = False
Set wbb = Workbooks.Add
For i = 1 To newwscnt
newwsmei = wsa.Cells(i, 1).Value
bl = True
For j = 1 To wbb.Worksheets.Count
If wbb.Worksheets(j).Name = newwsmei Then bl = False
Next j
If bl = True Then
Worksheets.Add after:=wbb.Worksheets(wbb.Worksheets.Count)
wbb.Worksheets(wbb.Worksheets.Count).Name = newwsmei
End If
Next i
If wbb.Worksheets.Count > newwscnt Then
Application.DisplayAlerts = False
For k = wbb.Worksheets.Count - newwscnt To 1 Step -1
wbb.Worksheets(k).Delete
Next k
Application.DisplayAlerts = True
End If
Application.ScreenUpdating = True
newwbmei = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
& "\" & Format(Now, "yymmdd_hhmmss") & ".xls"
If Dir(newwbmei) <> "" Then
AppActivate Application.Caption
MsgBox newwbmei & vbCrLf & "は既に存在するブック名です。"
Exit Sub
End If
wbb.SaveAs newwbmei
wbb.Close
Set wbb = Nothing
Set wsa = Nothing
Set wba = Nothing
End Sub

お礼

ありがとうございます。

この回答を見て確かに別ブックにできた方が
現在の使い方のニーズにあっていると思いました。
ご提案ありがとうございます。

うーん。ただ、マクロを実行しても
最後まで実行されエラーは起こらないのですが別ブックができません。
環境が悪いのか、マクロの使い方が悪いのか定かでないのですが・・・

回答No.8

marbin

#5です。
>うーん。ただ、マクロを実行しても
>最後まで実行されエラーは起こらないのですが別ブックができません。

↓の部分はあくまでもサンプルですので、実際に保存したいフォルダ及び
ブック名を指定してください。

>newwbmei = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
& "\" & Format(Now, "yymmdd_hhmmss") & ".xls"

> CreateObject("WScript.Shell").SpecialFolders("Desktop")
は、特殊フォルダで現在のユーザーのデスクトップを意味します。

>Format(Now, "yymmdd_hhmmss") & ".xls"
は、現在時刻を文字列化したものに拡張子を付与しています。

お礼

デスクトップ上にファイルができていることを確認しました。
どうもありがとうございました。
実はこれまでキーボードマクロしか使ったことがない初心者です。
がんばって覚えたいと思います。
ありがとうございました。

回答No.7

hige_082

必要コードのみ

Sub test()
Dim i, ii As Integer
i = Sheets.Count
Sheets.Add after:=Sheets(i), Count:=20
For ii = 1 To 20
Sheets(i + ii).Name = Sheets("sheet1").Cells(ii, 1).Value
Next ii
End Sub

参考まで

お礼

使ってみました。
できました。
ありがとうございます！

回答No.6

marbin

＃4,5です。

>newwbmei = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
>& "\" & Format(Now, "yymmdd_hhmmss") & ".xls"
>If Dir(newwbmei) <> "" Then
>AppActivate Application.Caption
>MsgBox newwbmei & vbCrLf & "は既に存在するブック名です。"
>Exit Sub
>End If

新規ブック生成後ブックを保存する直前に処理してますが、新規ブック生成前の
>Application.ScreenUpdating = False
の前あたりに処理を移したほうがいいですね。

お礼

ありがとうございます

回答No.4

marbin

エクセルVBAなら、

On Error Resume Next
処理
On Error Goto 0

とすれば既存のシートと同じシートを作ろうとしても
エラーをスキップして次に進んでくれます。

もちろん、ループで既存のシートとの重複チェックする
のが正しいやり方ですが。

お礼

ありがとうございます。

回答No.3

PoohBee

たびたび登場のPoohBee@エンジニアです。

実行結果は添付画像のようなイメージですが、ご質問されている内容と異なる場合はお知らせください。再回答致します。

お礼

イメージどおりです。

本題からそれますが
三四郎のシート名は上側にあるのですね。
ありがとうございました。

回答No.2

PoohBee

こんばんは。Poohbee @ エンジニアです。
やるべき主な処理としては、以下の4つですね。
・for文でA1～20までループしつつセル値を取得し
・シート名に取得した値と重複するものがあるかチェックした上で
・なければ取得した値をシート名に設定してシート追加
・追加後にシートの存在チェックしておく　←冗長なら不要かもです。

普段、社内ではExcelが全く使われていない環境にいるため、Excelが導入された環境がないんです…。三四郎ユーザなのでごめんなさい。
三四郎マクロで実現する際のコードを記載しておきます。
Excelで実装する際の参考にしてください。

******************************************************
!! Declare
　Declare begin
　const ColA as string = "A"
　variable %Result as boolean
End Declare

!! ↓Main()↓
!! シート追加
%Result = SheetAdd(ColA)
!! 実行結果をMsg表示
ResultMsg(%Result)
!! ↑Main()↑

!! Function
!! "Sheet1"A1～20から取得した値をシート名に利用してシート追加
Function SheetAdd(%Col as string ) as boolean
　for %i = 1 to 20 step +1
　!! セル値取得
　%GetValue = Worksheets("Sheet1").Range(%Col & %i).text
　!! 存在チェックしてからシート追加
　if Exist(Worksheets(%GetValue)) then
　　continue for !! すでにシートが存在するなら次へ
　else
　　set %AddSheetObj = Worksheets.Add(%GetValue,,1)
　　!! 追加したシートの存在チェック
　　if Exist(%AddSheetObj) then
　　　SheetAdd = true !! 返り値(成功：true)
　　　continue for !! シート追加して次へ
　　else
　　　SheetAdd = false !! 返り値(失敗：false)
　　　message("シート" & %GetValue & "の作成に失敗しました。")
　　end if
　end if
　next
End Function

!! シート追加処理の実行結果をMsg表示
Function ResultMsg(%Res as boolean)
　if %Res = true then
　　message("シート追加は成功しました")
　else
　　message("シート追加は失敗しました")
　end if
End Function

お礼

エラー処理など様々ありがとうございました。
三四郎の環境は持っていないので試すことはできませんが参考にします。

回答No.1

某HN クロメート(Chromate)（@CoalTar）

↓もっとうまいやり方があると思います
そのつなぎ
Sub Macro1()
Dim n As Byte
Dim ACC As String
ACC = ActiveSheet.Name
For n = 1 To 20
Sheets.Add.Move after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Worksheets(ACC).Cells(n, 1)
Next n
End Sub
シート名の書いてあるシートで実行します

お礼

すばやいご回答ありがとうございます。
試してみました。
ばっちりです。