シートを増やすVBAの実行エラー1004の解決方法と理由

2023/08/15 20:42

このQ&Aのポイント

シートを増やすVBAで実行エラー1004が発生する原因や解決方法についてご教授ください。
VBAでシート名を増やす際に実行エラー1004が発生する場合の解決方法を教えてください。
シートを増やすVBAを実行すると、実行エラー1004が発生することがあります。このエラーの解決策と原因についてお教えください。

ベストアンサー

シートを増やすVBA

2012/01/16 21:51

フィルタで隠れている場合もある列の値をシート名として増やしていくVBAで以下のようなものをつくりました（値は重複している場合もある）雛型シートがありそれをシート名だけ増やしていくというものです Sub シートを増やす() Dim target As Range Dim h As Range On Error Resume Next Set target = Worksheets("一覧シート").Range("E10:E" & Worksheets("一覧シート").Range("E65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible) If target Is Nothing Then Exit Sub 'シートを増やしていく For Each h In target On Error GoTo errhandle Worksheets(h.Value).Select On Error GoTo 0 Next Sheets("一覧シート").Select Exit Sub errhandle: Worksheets("雛型").Copy after:=Worksheets(Worksheets.Count) ActiveSheet.Name = h.Value Resume End Sub そうすると、実行エラー1004 ”シートの名前をほかのシート、Visual　Basicで参照されるオブジェクトライブラリまたはワークシートと同じ名前に変更することはできません。” というエラーがたまにおきます（シート名が数字の場合におきるようです）解決方法及び理由をご教授ください

kayomana
お礼率52% (101/191)

オフィス系ソフト
回答数2
ありがとう数2

みんなの回答 （2）
専門家の回答

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

ベストアンサー

emaxemax
ベストアンサー率35% (43/121)

2012/01/17 16:06 回答No.2

ANo1のemaxemaxです、やっぱりそうでしたか。 On Error GoTo errhandle Worksheets(h.Value).Select は、エラーとなる重複するシート名をさけるためですよね。その場合、h.Valueが文字列であれば問題ないのですが、数値の場合、たとえば h.Valueが10だとすると Worksheets(h.Value)は、Worksheets(10)となり、左から10番目のシートという意味になってしまいます。そうならないようにCstr関数でh.Valueをすべて文字に変えてみました。これで数値の10は文字列化するので Worksheets("10")というシートになります。

質問者

お礼 2012/01/20 11:45

なるほど、ほぼ完全に理解できましたありがとうございます

その他の回答 (1)

emaxemax
ベストアンサー率35% (43/121)

2012/01/16 23:01 回答No.1

> シート名が数字の場合におきるようですだとすれば、 On Error GoTo errhandle Worksheets(h.Value).Select これを On Error GoTo errhandle Worksheets(CStr(h.Value)).Select としたらどうなりますか？

質問者

お礼 2012/01/17 15:39

ありがとうございます。こちらで試したところ、問題なくエラーが起きずに実行完了いたしました

関連するQ&A

セルの値をシート名にするエクセルVBA
件名のVBAを以下のように書きました B列の４からずっと下までのセルの値を次々とシート「ひな型」をコピーし増やしていくものです。 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列のセルに複数同じ名前があった時に、既に作ったシートの名前がある場合それは無視するという風に実行したいですお知恵をお貸しくださいませ
- ベストアンサー
- Excel（エクセル）
VBAでChangeイベントを使いたい
今エクセルで出納を作ってます。シート1には　Ａ日付　Bコード　C金額　D　消費税区分　E　金額 F,G,H,Iにも同様に貸方科目を入れてます。シート2にはAコードB科目を上から下にずっといれてます。それで借方金額Ｃの金額をEに飛ばすこと VLOOKUPでＢのコードに対応する科目を表示すること上記をChangeイベントでやりたいのですが、金額転記はうまくいったのですが、 VLOOKUPの方が標準モジュールではうまくいくものの、シートモジュールに移すとうまく行きません。おそらく根本的な理解がかけてるからだと思います。今の記述は下記シート1に Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row = 1 Or Target.Row > 100 Then Exit Sub If Target.Column <> 5 Then Exit Sub Dim Cnt As Long For Cnt = 2 To 100 Range("I" & Cnt).Value = Range("E" & Cnt).Value Next Cnt If Target.Row = 1 Or Target.Row > 100 Then Exit Sub If Target.Column <> 3 Then Exit Sub End Sub 標準モジュールに Option Explicit Sub 科目() Dim シート1 As Worksheet Dim シート2 As Worksheet Set シート1 = Worksheets("出納") Set シート2 = Worksheets("科目") Dim myR On Error GoTo ErrorHandler myR = Application.WorksheetFunction.VLookup(シート1.Range("B2"), シート　　　　　　　　　2.Range("A2:B87"), 2, False) シート1.Range("C2").Value = myR Exit Sub ErrorHandler: シート1.Range("C2").Value = "該当無し" End Sub 　大変素人な質問ですみませんが、ご回答いただけると嬉しいです。　基礎の本やレファレンス本は見たのですが、標準モジュールでできること　がなぜシートモジュールでできないかが全く分かりません。　よかったらお教えください。
- 締切済み
- 財務・会計・経理
VBA　シート指定とファイル名入力
部署ごとに分割し、ブックで保存するコードです。 sheet名は「部署」です。 Sub macro1() Dim w As Worksheet Dim n As Long Dim r As Long Dim s As String Dim WSH As Variant Dim myPath As String Set w = ActiveSheet n = Worksheets.Count Application.ScreenUpdating = False On Error GoTo errhandle For r = 5 To w.Range("B65536").End(xlUp).Row s = w.Cells(r, "B") w.Rows(r).Copy Worksheets(s).Range("B65536").End(xlUp).Offset(1, -1) Next r On Error GoTo 0 Set WSH = CreateObject("Wscript.Shell") myPath = ActiveWorkbook.Path & "\1\" For r = Worksheets.Count To n + 1 Step -1 Worksheets(Worksheets.Count).Copy ActiveSheet.Columns.AutoFit ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name ActiveWorkbook.Close False Application.DisplayAlerts = False Worksheets(Worksheets.Count).Delete Application.DisplayAlerts = True Next r w.Select Exit Sub errhandle: Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = s w.Rows(1).Copy Range("A1") w.Rows(2).Copy Range("A2") w.Rows(3).Copy Range("A3") w.Rows(4).Copy Range("A4") Resume Application.ScreenUpdating = True End Sub (1)sheet1にマクロ実行ボタンを配置し、部署seedにマクロ実行命令をする。 (2)sheet1のB2セルにファイル名を入力して、そのファイルに保存する。（例部署ファイル） (1)Dim w As Worksheets("部署")と変更したのですが、エラーが出ました。 (2)myPath = ActiveWorkbook.Path & "\部署ファイル\"　　↑ これをsheet1のB2セルから指定できるようにしたいです。宜しくお願いします。
- ベストアンサー
- Visual Basic
VBAでコードの編集が上手くいきません
先日、ご回答頂いたコードを元に自分でいじっているのですが上手く行きません自分が変更したコードシート1→シート名：変更箇所 Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$C$40" Then Exit Sub If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value If Target.Address <> "$C$42" Then Exit Sub If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value If Target.Address <> "$C$44" Then Exit Sub If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value End Sub シート2→シート名：リスト Private Sub worksheet_change(ByVal Target As Excel.Range) Dim i As Long, c As Long Dim h As Range, ha As Range Dim myDic As Object Set ha = Application.Intersect(Target, Range("A:C")) If ha Is Nothing Then Exit Sub Set ha = Application.Intersect(ha.EntireColumn, Range("1:1")) For Each h In ha Set myDic = CreateObject("Scripting.Dictionary") If h.Column = 1 Then c = 3 'A列→C列 If h.Column = 2 Then c = 4 'B列→D列 If h.Column = 3 Then c = 6 'C列→F列 On Error Resume Next For i = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row If Cells(i, h.Column) <> "" Then myDic.Add Cells(i, h.Column).Value, Cells(i, h.Column).Value End If Next i With Worksheets("変更箇所").Cells(40, c).EntireColumn.Validation .Delete .Add Type:=xlValidateList, Formula1:=Join(myDic.keys, ",") End With Set myDic = Nothing Next End Sub シート1において$C$40または$C$42または$C$44のいずれかを変更した場合最後に変更したセルに対し、シート2にオートフィルタ―がかかる様にしたいと思っています。試しにシート1を以下のように編集したところ、思った動作を行ったのですが $C$40または$C$42または$C$44のいずれかのセルを空白にするとエラーがでてしまいます。 Private Sub worksheet_change(ByVal Target As Excel.Range) If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value End Sub Then Exit Subをどう編集すれば上手く動作するでしょうか？
- ベストアンサー
- オフィス系ソフト
VBA　CHANGEイベントに複数イベントを
いつもお世話になっています。色々しらべて試してみたんですが、うまくいかないんで教えてください。 CHANGEイベントに複数のイベントを書き込みたいんですが。今現在、問題なく動いている以下のイベントがあります。 (1) Private Sub Worksheet_Change(ByVal Target As Range) Dim rang3 As Range Dim rang4 As Range Dim ■■ As String Dim LastRow1 As Long LastRow1 = Worksheets("○○").Cells(Rows.Count, "b").End(xlUp).Row Set rang4 = Worksheets("○○").Range("b:I" & LastRow) Set rang3 = Range("h4") If Intersect(Target, rang3) Is Nothing Then Exit Sub On Error Resume Next ■■ = WorksheetFunction.VLookup(Target.Value, rang4, 2, 0) If Err.Number > 0 Then MsgBox Target.Value & "はありません。基本情報台帳に入力してください。" Range("h4").Select Else Application.EnableEvents = False Range("I4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 2, False) Range("j4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 3, False) Range("k4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 7, False) Range("l4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 8, False) Range("m4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 5, False) Application.EnableEvents = True Range("K4").Select End If End Sub このシートにもう一つ、イベントを入れたいのですが。 (2) If Target.Count > 1 Then Exit Sub If Intersect(Target, Range("E4")) Is Nothing Then Exit Sub Else If Range("e4").Value = "1" Then Target.Offset(0, 19).Value = "☆" End If どこに入れればいいのかわかりません。 (3) また、(2)のイベントの他に、 (1)のＶＬＯＯＬＵＰが実行され、尚且つ(2)のイベントのＥ４が値が１だった場合、Ｙ４にＨ４の値を入れたいのですが・・・。 (2)のみなら動くことは確認できましたが、(1)のｅｘｉｔ　ｓｕｂ　の直前に入れたり、ｅｎｄ　ｉｆの前に入れたりしましたが、片方は動くが、もうひとつが動かないです。 (3)については、まったくわかりません。マクロについて、自分でネットで勉強した程度なので、基本がわかっていないからなのでしょうが・・・。どなたか、教えてください。お願いします。
- ベストアンサー
- Visual Basic
エクセルVBAで名前の決まっているシートの倍率変更
早速ですが名前の決まっているそれぞれのシートがあります実際にはA,B,C、D７月、E６月と今月と先月の数字が入っています。それぞれのシートはいつもあるとは限らない為エラー処理をしましたが、なぜかうまくいきません。下記の例ではsheet7、sheet5、sheet3。とありそれぞれの倍率に合わせた後に最後にsheet７のシートに戻るようにしましたがe2:のラインで止まってしまいます。練習ではなく実際に必要なマクロなので、助言して頂ければ幸いです。よろしくお願いします。 Sub bairitu() Worksheets("sheet" & Month(now())).Select '7 ActiveWindow.Zoom = 60 On Error GoTo e1 Worksheets("sheet" & Month(now()) - 1).Select '6 ActiveWindow.Zoom = 70 e1: On Error GoTo e2 Worksheets("sheet" & Month(now()) - 2).Select '５ ActiveWindow.Zoom = 80 e2: On Error GoTo e3 Worksheets("sheet" & Month(now()) - 3).Select '４ ActiveWindow.Zoom = 50 e3: Worksheets("sheet" & Month(now())).Select End Sub
- ベストアンサー
- オフィス系ソフト
マクロ　一覧からシートを作成する
いつも回答して頂き、とても感謝しています。似た様な質問を過去にしていますが、前回の質問は、一列にシート名が記載しており、これを参照してシートを次々と挿入するマクロの作り方でしたが、今回は、複数列にシート名が記載されている場合のマクロ記述についてです。自分なりに考えてみましたが、set = s の値がNOTHINGになり、挿入したシートに名前を記載する事ができませんでした。原因がさっぱり分からないので御教授の程宜しくお願い致します。 Sub シートの挿入() Dim s As Worksheet Dim r As Long Dim c As Long On Error GoTo errhandle c = 2 With Worksheets("作業名一覧") For r = 2 To .Cells(Rows.Count, c).End(xlUp).Row Do While .Cells(r, c).Value <> "" Set s = Worksheets(Cells(r, c).Value) c = c + 1 Loop Next r End With Exit Sub errhandle: Worksheets.Add after:=Worksheets(Worksheets.Count) Worksheets(Worksheets.Count).Name = Cells(r, c).Value Worksheets(h.Value).Cells.ColumnWidth = 1 Worksheets(h.Value).Cells.RowHeight = 15 Resume End Sub
- ベストアンサー
- オフィス系ソフト
VBAでエラートラップがうまくいきません。
VBAで次のようなプロシージャを実行してみました。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) 　　If Target.Value = " " Then 　　　　　　　　～コード～　　END IF END SUB すると複数のセルが選択されるとエラーがでます。そこで次のようにしてみました。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) 　　On Error GoTo エラー処理　　If Target.Value = " " Then 　　　　On Error GoTo 0 　　　　　　　　　～コード～　　END IF 　　EXIT SUB エラー処理: 　　EXIT SUB END SUB ところがこれでもやっぱりIF文のところでエラーがでます。当方初心者でなぜエラーがでるのかわかりません。わかりやすくご教授ください。よろしくお願いします。
- ベストアンサー
- Visual Basic
Excel　VBAについて
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, cancel As Boolean) If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub Application.Goto Worksheets("人件費").Range("A1") Worksheets("人件費").Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = Target.Offset(, -5).Value cancel = True End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, cancel As Boolean) If Intersect(Target, Range("G:G")) Is Nothing Then Exit Sub Application.Goto Worksheets("外注費").Range("A1") Worksheets("外注費").Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = Target.Offset(, -5).Value cancel = True End Sub 上の指令はFの列をダブルクリックすると人件費のシートが開いてAある値を人件費の新しいセルのAに代入する指令ですがそれをG列ダブルクリックで外注費シートに同じようにやろうと思いましたが出来ません。たぶん根本的に書き方が間違っているのかと思われますが、ご指導のほどお願いします。
- ベストアンサー
- Excel（エクセル）
セルの値をワークシート名にする(エクセル2013)
インストラクターのネタ帳さんより http://www.relief.jp/itnote/archives/003382.php 下記「セルの値をワークシート名にする?Worksheet_Change」を拝借し利用させていただこうと思いましたが ---------------------- Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ERR_HANDLER If Target.Address(False, False) = "H1" Then ActiveSheet.Name = Range("H1").Value End If Exit Sub ERR_HANDLER: MsgBox "現在のH1セルの値はシート名にできません。" End Sub ---------------------- はそのまま出来るのですが、 H1セルにデータの入力規則：リストを指定しますとエラーとなりシート名が変わりません sheet1のリストA1:A50をsheet2のH1セルにリスト表示させその表示名をそのままシート名に出来ませんでしょうか？ ---------------------- Sub copy Range("H1").Copy Range("P1") End Sub ---------------------- Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ERR_HANDLER If Target.Address(False, False) = "P1" Then ActiveSheet.Name = Range("P1").Value End If Exit Sub ERR_HANDLER: MsgBox "現在のP41セルの値はシート名にできません。" End Sub ---------------------- としてH1のセルをP1にコピーしたものを指定して試しましたがやはりエラーとなりうまくいきませんでした。全くの素人で恐縮ですがよろしくお願いいたします
- ベストアンサー
- Excel（エクセル）