• ベストアンサー
※ ChatGPTを利用し、要約された質問です（原文：追加の質問ですが、シートを一致させたい。）

シートを一致させたい

このQ&Aのポイント
  • シートを一致させるために、NEWBOOKにあってOLDBOOKにないシートはNEWBOOKからOLDBOOKに挿入し、OLDBOOKにあってNEWBOOKにないシートはOLDBOOKから削除します。
  • 上記のコードを使用して、まずNEWBOOKにあってOLDBOOKにないシートを複写し、次にOLDBOOKにあってNEWBOOKにないシートを削除します。
  • 最後にシートを並び替えます。

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

  • ベストアンサー
  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.1

For Each shDst In OLDBOOK.Sheets において If shDst Is Nothing Then が成立するとは思えませんが。。。 だってOLDBOOKには存在しているわけですし。 shSrc　で判断するのでは？

yokokama46
質問者

お礼

n-junさんありがとうございました。 むむっ！てな感じです。よく見たつもりでしたが、見落としでした。なかなか自分では気づけないものですね。助かりました。

全文を見る
すると、全ての回答が全文表示されます。
  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • EXCEL2007ではOKですが2003だとエラーになる

    よろしくお願いします。 下記のコード（抜粋）がエクセル2007では全く問題なく動くのに、2003だとエラーになってしまうというもので困ってしまいました。 下記は二つのファイルの構成を比較して（OLDBOOKのシートをNEWBOOKと同じ構成にする）追加、削除、並び替えを行うというものです。 残念ながら、当方2003を持ってないので確認が出来ません。（当然配布は互換形式） 各配布先で試してもらったところ、2007のところは問題なし。2003のところはすべてエラーとなり、エラー箇所は抜粋している範囲のさらに2つのファイルを比較し、必要に応じて追加、削除を行う部分です。 Set shDst = OLDBOOK.Sheets(shSrc.Name) と Set shSrc = NEWBOOK.Sheets(shDst.Name) の部分で「454のオブジェクトエラー」となるとのことでした。原因は、そこにあると思いましたが、2007では問題ないので、何が悪いのかさっぱりです。どなたか助けて下さい。 Dim FIRSTBOOK As Workbook Dim OLDBOOK As Workbook Dim shSrc As Object Dim shDst As Object ～省略 ～ '現在の再計算モードの取得 iOldCalculation = Application.Calculation '再計算モードを手動に設定 Application.Calculation = xlManual '*****ここから比較***** ' // まず NEWBOOK.xls にあって OLDBOOK.xls にないシートをOLDBOOK.xls に複写 For Each shSrc In NEWBOOK.Sheets On Error Resume Next Set shDst = OLDBOOK.Sheets(shSrc.Name) On Error GoTo 0 If shDst Is Nothing Then shSrc.Copy After:=OLDBOOK.Sheets(OLDBOOK.Sheets.Count) End If Set shDst = Nothing Next ' // 続いてNEWBOOK.xls　になくてOLDBOOK.xls にあるシートをOLDBOOK.xls　から削除 For Each shDst In OLDBOOK.Sheets On Error Resume Next Set shSrc = NEWBOOK.Sheets(shDst.Name) On Error GoTo 0 If shSrc Is Nothing Then shDst.Delete End If Set shSrc = Nothing Next ' // シート並べ替え For Each shDst In OLDBOOK.Sheets shDst.Move Before:=OLDBOOK.Sheets(NEWBOOK.Sheets(shDst.Name).Index) shDst.Protect DrawingObjects:=True, Contents:=True, UserInterfaceOnly:=True Next '再計算モードの復元 Application.Calculation = iOldCalculation NEWBOOK.Close (False) '有無を言わずに保存せず閉じる ～省略 ～

  • 配列処理を遅くてもよいので軽い処理に変えたい。

    　よろしくお願いします。 　抜粋のコードをメモリーに負荷をかけない処理に変えたいのです。 　下記は二つのファイルの構成を比較して（OLDBOOKのシートをNEWBOOKと同じ構成にする）追加、削除、並び替えを行うというものです。 しかし、メモリーの問題でシート数が30を超えると（環境によっては40枚位まではOK）Sheets.Countが狂い結果エラーに結び付くのです。 そこで、メモリーの負担を軽くするため、一気に配列に呼び込むのではなく、遅くなってもいいので、一つずつ比較するやりかたをご教示願えないかという次第です。 　なお補足ですが、シートは関数などがぎっしり書き込まれているので、重いものなのです。それをBOOKに出来れば100枚位まで入るようにしたいのです。 　ネット上で「一つのBOOKに何枚までシートを挿入出来るか？」というのを見ましたが、やはりメモリーに依存し（物理メモリーではなく）空のシートなら65000枚とかまででもOKですが、重いシートだと30枚位からダメになるとありましたので、実は今回の省略の前の部分でシートをCopy Afterで別BOOKに追加していくという形が有ったのですがここでもエラーでした。その内容はやはりSheets.Countが30を過ぎたら狂い（50枚入れる指示にもかかわらず31枚目を挿入時、シートカウントが7とかに戻ってしまう）そこで必要な枚数をCopy Afterで挿入して行かずに、先に空シートを必要な枚数作らせたBOOKのシートをまとめて、今回のシートを貼り付ける作業に変えたところ、100枚でもOKになり、そこはクリアしたのですが、今回の抜粋の所で引っかかってしまいました。 同じように遅くなっても軽い処理に下記コードを直したいのです。助けて下さい。 Dim NEWBOOK As Workbook Dim OLDBOOK As Workbook Dim shSrc As Object Dim shDst As Object ～省略 ～ '現在の再計算モードの取得 iOldCalculation = Application.Calculation '再計算モードを手動に設定 Application.Calculation = xlManual '*****ここから比較***** ' // まず NEWBOOK にあって OLDBOOK にないシートをOLDBOOK に複写 For Each shSrc In NEWBOOK.Sheets On Error Resume Next Set shDst = OLDBOOK.Sheets(shSrc.Name) On Error GoTo 0 If shDst Is Nothing Then shSrc.Copy After:=OLDBOOK.Sheets(OLDBOOK.Sheets.Count)　　　←ここで実行時エラー（1004　コピー先の行数が足りないため～） End If Set shDst = Nothing Next ' // 続いてNEWBOOK　になくてOLDBOOK にあるシートをOLDBOOK　から削除 For Each shDst In OLDBOOK.Sheets On Error Resume Next Set shSrc = NEWBOOK.Sheets(shDst.Name) On Error GoTo 0 If shSrc Is Nothing Then shDst.Delete End If Set shSrc = Nothing Next ' // シート並べ替え For Each shDst In OLDBOOK.Sheets shDst.Move Before:=OLDBOOK.Sheets(NEWBOOK.Sheets(shDst.Name).Index) shDst.Protect DrawingObjects:=True, Contents:=True, UserInterfaceOnly:=True Next '再計算モードの復元 Application.Calculation = iOldCalculation NEWBOOK.Close (False) '有無を言わずに保存せず閉じる ～省略 ～

  • 保護されたブックのコピーについて

    現在、ボタンを押すと新規ブックが作成され、最初のブックのシートをコピーするというマクロを組みました。 しかし、元になるブックにはブックの保護とシートの保護を両方かけていて、途中でエラーになるはずなのですが、何故かそうならずに普通に新規ブックにコピーがされます。 上手くいったのですがエラーが出ると予想していたので気持ちが悪く、また個人だけで使うわけじゃないので原因を知っておきたいです。 どなたかよろしくお願いします。 Private Sub makeBookButton_Click() Dim myWorkBook As String Dim newWorkBook As String Dim mySheet As Worksheet Application.ScreenUpdating = False On Error GoTo ErrTrap Application.DisplayAlerts = False myWorkBook = ThisWorkbook.Name Workbooks.Add ActiveWorkbook.SaveAs Filename:=NEWBOOK newWorkBook = ActiveWorkbook.Name Workbooks(myWorkBook).Activate For Each mySheet In ThisWorkbook.Worksheets Workbooks(myWorkBook).Sheets(mySheet.Name).copy after:=Workbooks(newWorkBook).Sheets(Workbooks(newWorkBook).Sheets.Count) Next Workbooks(NEWBOOK).Sheets("Sheet1").Delete Workbooks(NEWBOOK).Sheets("Sheet2").Delete Workbooks(NEWBOOK).Sheets("Sheet3").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True Exit Sub ErrTrap: Call MsgBox("ブック作成時にエラーが発生しました。", vbCritical) End Sub

  • シートを増やすVBA

    フィルタで隠れている場合もある列の値を シート名として増やしていく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で参照されるオブジェクトライブラリまたはワークシートと同じ名前に変更することはできません。” というエラーがたまにおきます（シート名が数字の場合におきるようです） 解決方法及び理由をご教授ください

  • ワークシートを上書き保存したい

    Excel2003でマクロ初心者です。 以下のコードでシートを上書き保存したいのですが 次々と複写され、上書きされません。どうコードをかえたらよろしいでしょうか。 Private Sub CommandButton10_Click() Dim wb As Workbook On Error Resume Next '開いて作業中の場合。 Set wb = Workbooks("最新表.xls") On Error GoTo 0 If wb Is Nothing Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\表の保存箱\最新表.xls") End If Worksheets("確定").Copy after:=Workbooks("21年計算01.xls").Sheets("総括表") 'Workbooks("最新表.xls").Close End Sub 最新表.xlsは文字通り、最新ですので常に上書きしたいのです。

  • VBAエクセルにて開いてないエクセルシートを開いてるシートに所得

    お世話になります。 「同じフォルダー内にBOOKが2つ有ります。1つ（AK.xls）を立上げて もう1つの（EX.xls）を立上げずに、EX.xls内のSheet1をコピーして AK.xlsのシート（STEP1）に貼り付けようとしています。」 どうしてもエラーが出てしまいます。 何方か、分かる方教えて下さい。 また記述して戴ければもっと助かります。 エラーは”1004”EX.xlsが見つかりません。と出てしまいます。 Sub ST() Dim wsSrc As Worksheet, WS As Worksheet Dim PasteR As Range Dim x As Long Sheets("STEP1").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select 　　Set wsSrc = ActiveSheet Workbooks.Open "EX.xls" For Each WS In Worksheets x = WS.Range("A1").CurrentRegion.Rows.Count If WS.Index = 1 Then Set PasteR = wsSrc.Range("A1") Else Set PasteR = wsSrc.Range("A65536").End(xlUp).Offset(1) End If WS.Range(WS.Cells(1, 1), WS.Cells(x, 44)).Copy PasteR Set PasteR = Nothing Next ActiveWorkbook.Close False Set wsSrc = Nothing End Sub デバックでは Workbooks.Open "EX.xls"この部分が黄色になります。 是非、回答を宜しくお願い致します。

  • セルの値をシート名にするエクセル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列のセルに複数同じ名前があった時に、既に作ったシートの名前がある場合 それは無視するという風に実行したいです お知恵をお貸しくださいませ

  • VBAの表からシートを作成したい

    現在の構文は以下のようになっています。 Dim ws As Range For Each ws In Worksheets("ユーザー情報").Range("C2:C201") On Error GoTo myError If Not ws Is Nothing Then Worksheets("雛形").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.name = ws.Value End If Next ws Exit Sub myError: nm = "雛形 (2)" For Each sh In Worksheets If sh.name = nm Then Application.DisplayAlerts = False Worksheets(nm).Delete Application.DisplayAlerts = True End If Next 「ユーザー情報」シートのC列に氏名を記入して上記マクロを実行すれば、その氏名ごとに「雛形」を元にしたシートが連続でコピーされる形になっています。 しかし、1度実行した後、あらたにC列に氏名を追加してもその分のコピーを作ってくれなくなります。 どのようにすればよいでしょうか。アドバイスをいただければと思います。

  • ■シートを一つ削除するマクロを教えてください。

    前に、http://oshiete1.goo.ne.jp/qa4352149.html で質問させて頂きました。 その節は、お世話になりありがとうございました。 今回は、前回と似たようなものですが、 少々条件を変更したマクロを作成したいので ご協力のほど、何卒よろしくお願い致します。 文末にマクロを記述いたしますが、そちらは、 指定した日付以降にエクセルのファイルを開くと シートがすべて削除されて、「有効期限切れ」という シートだけが出てくるというものです。 今度は例えば「SheetA」、「SheetB」、「SheetC」という 3つのシートがあったとして、 指定した期日が来たら、「SheetC」だけを削除したいのです。 条件があり、「SheetC」は、マクロを有効にしないと使用できないようにしたいのです。 やり方をご存知の方、ご教示のほど 何卒よろしくお願い致します。 Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) endsheetname = "有効期限切れ" If (Sheets.Count = 1) And (Sheets(1).Name = endsheetname) Then Exit Sub If Sheets("SheetA ").Visible Then Sheets("SheetC ").Visible = xlVeryHidden End Sub Private Sub Workbook_Open() endsheetname = "有効期限切れ" If Date >= "3008/09/29" Then Application.DisplayAlerts = False If Sheets.Count = 1 Then If Sheets(1).Name <> endsheetname Then Sheets.Add(After:=ActiveSheet).Name = endsheetname End If Else On Error Resume Next Sheets(endsheetname).Delete On Error GoTo 0 Sheets.Add(After:=ActiveSheet).Name = endsheetname End If sheetnumber = Sheets.Count For i = 1 To sheetnumber For j = 1 To 2 If Sheets.Count = 1 Then Exit For If Sheets(j).Name = " SheetC " Then If Not Sheets("SheetC ").Visible Then Sheets("SheetC ").Visible = True If Sheets(j).Name <> endsheetname Then Sheets(Sheets(j).Name).Delete: Exit For Next Next Range("b" & 3).Value = "ご利用ありがとうございました。" ActiveWorkbook.Save Application.DisplayAlerts = True End If If (Sheets.Count = 1) And (Sheets(1).Name = endsheetname) Then Exit Sub If Not Sheets(" SheetC ").Visible Then Sheets(" SheetC ").Visible = True End Sub

  • 指定シートの有無を確認

    指定したシートの有無を確認するVBAを作っているのですがうまく作動しません。 Sub dummy() Dim dummy Dim sheetname As String sheetname = Sheets("入力").Cells(1, 1).Value　'←『入力』というシートのセルA1と同じ値のシート名 On Error Resume Next Set dummy = sheetname If Err.Number = vbnomal Then flag = True On Error GoTo 0 If flag Then Msgbox "シートがあります" Else Sheets("原紙").Copy before:=Sheets(1) Worksheets(1).Name = sheetname End Sub 補足：入力というシートのA1に値が入っており、その値と同じシートがあればメッセージが出る、無ければ『原紙』というシートをコピーしてコピーしたシートのタブにA1の値を表示する

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する