No.5ベストアンサー
- 回答日時:
別ブックで作成するサンプルです。
エラー処理(念のための二重エラー処理もあり)がいくつかありますので長ったらしくなっていますが・・・。
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
- 回答日時:
#5です。
>うーん。ただ、マクロを実行しても
>最後まで実行されエラーは起こらないのですが別ブックができません。
↓の部分はあくまでもサンプルですので、実際に保存したいフォルダ及び
ブック名を指定してください。
>newwbmei = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
& "\" & Format(Now, "yymmdd_hhmmss") & ".xls"
> CreateObject("WScript.Shell").SpecialFolders("Desktop")
は、特殊フォルダで現在のユーザーのデスクトップを意味します。
>Format(Now, "yymmdd_hhmmss") & ".xls"
は、現在時刻を文字列化したものに拡張子を付与しています。
デスクトップ上にファイルができていることを確認しました。
どうもありがとうございました。
実はこれまでキーボードマクロしか使ったことがない初心者です。
がんばって覚えたいと思います。
ありがとうございました。
No.6
- 回答日時:
#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.2
- 回答日時:
こんばんは。
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
- 回答日時:
↓もっとうまいやり方があると思います
そのつなぎ
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
シート名の書いてあるシートで実行します
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) エクセルのマクロについて教えてください。 1 2022/08/04 13:56
- Visual Basic(VBA) エクセルのマクロについて教えてください。 1 2022/10/11 12:55
- Excel(エクセル) Excelについて 1 2023/03/06 10:26
- Excel(エクセル) 添付写真上のExcelシートのように時間と曜日ごとに担当者が振り分けられているシートがあります。 例 1 2023/03/08 13:02
- Excel(エクセル) エクセルのマクロについて教えてください。 1 2023/02/25 16:07
- Excel(エクセル) 同じExcelのBOOK内で 1枚目のシートのA1のセルにデータを 入れると2枚目のシートのC1のセ 1 2022/10/25 09:40
- Excel(エクセル) VBA ふたつの同じ様式シートのセルをコピーしたい 2 2023/03/08 15:28
- Excel(エクセル) ExcelVBA メモ帳を起動し名前を付けて指定フォルダに保存 2 2022/04/18 13:15
- Visual Basic(VBA) エクセルのマクロで対象ごとにシート分けしてその内容をセルに書き込みたい 9 2022/08/24 13:23
- Visual Basic(VBA) VBAマクロでシートコピーした新シートにコピー元シートとの計算式の入れ方を教えて下さい。 5 2022/11/20 09:48
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルの複数シートの保護を...
-
Excelで同じシートのコピーを一...
-
EXCELで1ヶ月分の連続した日付...
-
Excelで金銭出納帳。繰越残高を...
-
別シート参照のセルをシート毎...
-
エクセルVBAでパスの¥マークに...
-
VBAでシートコピー後、シート名...
-
スプレッドシートの関数VLOOKUP...
-
エクセル(VBA)でリストボック...
-
前の(左隣の)シートを連続参...
-
複数のシートにまたがるデータ...
-
エクセルでファイル保存時に複...
-
基本となるシートをコピーした...
-
複数のピボットを同じフィルタ...
-
シートの保護のあとセルの列、...
-
EXCEL:同じセルへどんどん足し...
-
エクセルif関数で、複数のシー...
-
エクセルで前のシートを連続参...
-
全シートを選択し、それぞれ特...
-
別シートの最終行に貼り付けす...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excelで同じシートのコピーを一...
-
エクセルの複数シートの保護を...
-
Excelで金銭出納帳。繰越残高を...
-
エクセルでファイルを開いたと...
-
EXCELで1ヶ月分の連続した日付...
-
エクセルVBAでパスの¥マークに...
-
EXCEL:同じセルへどんどん足し...
-
シートの保護のあとセルの列、...
-
別シート参照のセルをシート毎...
-
エクセルで前のシートを連続参...
-
前の(左隣の)シートを連続参...
-
EXCELで同一フォーマットのシー...
-
VBAでシートコピー後、シート名...
-
Excel 連番を入力する方法
-
エクセル 計算式も入っていない...
-
エクセルで前シートを参照して...
-
エクセルでシート名を自動入力...
-
Accessのスプレッドシートエク...
-
複数シートの特定の位置に連番...
-
エクセルのシート名をリスト化...
おすすめ情報