• 締切済み

プログラムの手直しを手伝って頂けないでしょうか?

した記載のサンプルプログラムの手直しを手伝って頂けないでしょうか? どうしても以下の問題が克服できずに困っています。 宜しくお願い致します。 ※コピー元を非表示にしてVBAでコピーすると、設定していた印刷範囲がリセットされるのを回避したい。 ※コピーしたワークシートを最後(右側)に置きたい。 ※コピーしたワークシート名を日付(201408XX)としたい。  同日にワークシートをもう一枚コペーした場合は(201408XX_(1))とかにしてエラー回避をしたい。 Sub サンプル() ' Dim sc As Integer ' sc = Application.SheetsInNewWorkbook ' Application.SheetsInNewWorkbook = 1 ThisWorkbook.Sheets("オリジナル").Cells.Copy 'コピー With Worksheets.Add 'シート追加 .Range("A1").PasteSpecial Paste:=xlValues '値貼り付け .Range("A1").PasteSpecial Paste:=xlFormats '書式貼り付け .Name = "コピー" End With Application.CutCopyMode = False ' Application.SheetsInNewWorkbook = sc ' ActiveWorkbook.Close ' ThisWorkbook.Activate End Sub

みんなの回答

  • cj_mover
  • ベストアンサー率76% (292/381)
回答No.2

#1、cjです。#1にて訂正が1点。 誤) On erro GoTo 0 ' ◆ 正) On Error GoTo 0 ' ◆ 以上訂正をお願いします。 投稿前に動作確認したコードでは正しく書かれていたのですが、 投稿文を編集する際に何らかの原因で書き換えてしまったようです。 今日になって再度、意地悪な条件を加えて動作確認してみましたが、 上記修正を加えれば、私が理解するところの要求仕様に適う動作結果は得られています。 余計なお手間をおかけしてスミマセン。 尚、提示した処理の前後に、他の処理を書き足す場合は、 Dim sShName As String  の次の行位置に挿入 Exit Sub  の前の行位置に挿入 という要領になります。 以上、失礼しました。

  • cj_mover
  • ベストアンサー率76% (292/381)
回答No.1

こんにちは。 Worksheets.Add 部分も統一して ThisWorkbook.Worksheets.Add にした方がいい場合もあるし、 実は(ThisWorkbook以外の)アクティブブックにコピーしたい等そのままでいい場合もあるのかも知れませんし、 この点はそちらで確認してみてください。 一般的には、 ThisWorkbook.Sheets("オリジナル")をWorksheet型変数にSetするとか、   With ThisWorkbook.Sheets("オリジナル") 文字列型変数 = .PageSetup.PrintArea     .Cells.Copy 'コピー   End With のように文字列型変数に必要な値を格納しておくとか、 の方が正当ですが、 そこまで重要では(優先されることではあり)ありませんし、 解り易さ(変更点)を強調する意味で ThisWorkbook.Sheets("オリジナル")を繰り返し書いています。    ◆のアイコンで示した行は、 > 同日にワークシートをもう一枚コペーした場合は(201408XX_(1))とかにしてエラー回避をしたい に対応する為に追加(書換え)した記述です。 同日のワークシートコピーは(あっても)少量と見込んで、一番簡単な方法で対策しています ' ' /// Sub Re8730357() Dim sShName As String ' ◆ 同日にワークシートをもう一枚コペーした場合は(201408XX_(1))とかにしてエラー回避をしたい。   ThisWorkbook.Sheets("オリジナル").Cells.Copy 'コピー   ' ' ※コピーしたワークシートを最後(右側)に置きたい   With Worksheets.Add(After:=Sheets(Sheets.Count)) 'シート追加     .Range("A1").PasteSpecial Paste:=xlValues '値貼り付け     .Range("A1").PasteSpecial Paste:=xlFormats '書式貼り付け     sShName = Format(Date, "yyyymmdd") ' ◆ On Error GoTo ReName_ ' ◆     ' ' ※コピーしたワークシート名を日付(201408XX)としたい。     .Name = sShName ' ◆ On erro GoTo 0 ' ◆     ' ' ※コピー元を非表示にしてVBAでコピーすると、設定していた印刷範囲がリセットされるのを回避したい。     ' ' 新しいシートの印刷範囲を設定する必要がある→.PageSetup.PrintAreaをコピーする。     .PageSetup.PrintArea = ThisWorkbook.Sheets("オリジナル").PageSetup.PrintArea   End With   Application.CutCopyMode = False Exit Sub ' ◆ ReName_: ' ◆   sShName = Format(Date, "yyyymmdd (") & Val(Split(sShName & " (", " (")(1)) + 1 & ")" ' ◆   Resume ' ◆ End Sub

komio777
質問者

お礼

こんばんわ。 細かく指導して頂き有難うございます。 全てを理解できるように頑張ってみます。 まずは検証してみます。 有難うございます。

関連するQ&A

  • ワークシートをコピーしたい

    下記載のサンプルマクロは「ワークシートをコピーして、追加したワークブックにコピペする」マクロなんですが、これを「ワークシートをコピーして、追加したワークシートにコピペする」にできないでしょうか? 出来るのであれば、値と書式の他に関数もそのまま貼り付けたいので御教授お願いします。 ただマクロは削除してマクロ抜きのコピペが理想です。 宜しくお願い致します。 Sub サンプル() Dim sc As Integer sc = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1 ThisWorkbook.Sheets("オリジナル").Cells.Copy 'コピー Workbooks.Add 'ブック追加 Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlValues '値貼り付け Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlFormats '書式貼り付け Sheets("Sheet1").Name = "コピー" Application.CutCopyMode = False Application.SheetsInNewWorkbook = sc ActiveWorkbook.Close ThisWorkbook.Activate End Sub

  • アドバイスをお願いします(VBAで・・・)

    Excel2010を使用。 現在".xlsm"ファイルに シートが複数あります。 この中の一つのシートだけを新たなBookにコピーして、 名前を付けて保存する際、Book名を、"L5"セルにある文字列に したいと思い、ググった結果、下記のコードにたどりつきました。 このコードだけだと"close"の時にダイアログがでてくるので、 これに ActiveWorkbook.SaveAs Filename:="フォルダ名" & Range("L5").Value & ".xlsx" をCloseの前に挿入してみたのですが、Range("L5").Value=Empty値となり エラーがでてしまいます。 VBA初心者であるため、改善策がわからず苦戦しております。 申し訳ありませんが、アドバイスいただけないでしょうか? Sub サンプル() Dim sc As Integer sc = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1 ThisWorkbook.Sheets("オリジナル").Cells.Copy 'コピー Workbooks.Add 'ブック追加 Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlValues '値貼り付け Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlFormats '書式貼り付け Sheets("Sheet1").Name = "コピー" Application.CutCopyMode = False Application.SheetsInNewWorkbook = sc ActiveWorkbook.Close ThisWorkbook.Activate End Sub 参考URL:http://okwave.jp/qa/q2167570.html ※コピーしたいのは、シートの中のデータ、書式だけなので マクロを必要としません。

  • エクセルVBAで作成した別ブックにVBAを記述したい

    VBAで別ファイルの作成は下記で出来ているのですが、出来上がったファイルにVBAを記述する方法がわかりません。 具体的には一番下のSub TEST()を新しいブックの標準モジュールに記述したいのと、sheet1に Private Sub Worksheet_Change(ByVal Target As Range) MsgBox "ChangeTEST" End Sub を入れたいです。 また Private Sub Workbook_Open() MsgBox "OpenTEST" End Sub も入れたいのです。 どうぞご教示ください。 Sub 複製() Dim wb As Workbook, sc As Integer sc = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1 Set wb = Workbooks.Add Application.SheetsInNewWorkbook = sc wb.Sheets("Sheet1").Select ThisWorkbook.Sheets("Sheet1").Cells.Copy wb.Sheets("Sheet1").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Buttons.Add(123, 195, 68.25, 15).Select Selection.OnAction = "TEST" Selection.Characters.Text = "TEST" ActiveWorkbook.Close ThisWorkbook.Activate Sheets("Sheet1").Select End Sub Sub TEST() MsgBox "TEST!!" End Sub よろしくお願いします。

  • VBA空白を除いてコピーが出来ません。ご指導お願いします。

    値のコピー&ペースト(空白を除いてコピー)したいと思っております。 シート1 の A35、D35、I35 をコピー。 シート2 の A2 に貼り付け。 これは、大丈夫です。 シート1 の M2 : O23 をコピー。 シート2 の E2 に貼り付け。 今回の場合ですと、M2 : O13 までに値が入ってます。 ですので、M14 : O23 までが、空白になって記入となってしまいます。 *毎回、値が入る量が違います。 一回のコピーですと、これでもいいのですが、 値を変更して、コピーを続けてしますので、M14 : O23 までが、空白になってM24からのコピーになってしまいます。 空白を除いて、貼り付けしたいのですが、 どうすればいいのかわかりません。 お分かりになる方、ご指導よろしくお願いします。 VBAは以下になっております。 Sub Macro1() ' Application.ScreenUpdating = False Sheets("Sheet1").Range("A35,D35,I35").Copy If Sheets("Sheet2").Range("A2").Value = "" Then Sheets("Sheet2").Range("A2").PasteSpecial Paste:=xlPasteValues Else Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues End If Sheets("Sheet1").Range("M2:O23").Copy If Sheets("Sheet2").Range("E2").Value = "" Then Sheets("Sheet2").Range("E2").PasteSpecial Paste:=xlPasteValues Else Sheets("Sheet2").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues End If Application.CutCopyMode = False Application.ScreenUpdating = True End Sub よろしくお願いします。

  • 【VBA】コピー&複数個所のペースト繰り返し

    下記のように、1つの値をコピーし、別シートの複数個所(同じ列の違う行)へ順次ペーストしたいのですが、貼付けデータやペースト箇所が増えた場合でも対応できるようなVBAを教えてください。 よろしくおねがいいたします。 ========================================================= Sub コピペ() '←1人目をコピー Worksheets("“コピー元シート”").Range("B7").Select Selection.Copy '←貼付け Worksheets(“貼付シート”).Range("B9", "B37", "B65", "B93", "B121", "B149", "B177").Select Selection.PasteSpecial Paste:=xlPasteFormulas '←2人目をコピー Worksheets("“コピー元シート”").Range("B8").Select Selection.Copy '←貼付け Worksheets(“貼付シート”).Range("B11", "B39", "B67", "B95", "B123", "B151", "B179").Select Selection.PasteSpecial Paste:=xlPasteFormulas '←3個の値をコピー Worksheets("“コピー元シート”").Range("B9").Select Selection.Copy '←貼付け Worksheets(“貼付シート”).Range("B13", "B41", "B69", "B97", "B125", "B153", "B181").Select Selection.PasteSpecial Paste:=xlPasteFormulas '←4個の値をコピー Worksheets("“コピー元シート”").Range("B10").Select Selection.Copy '←貼付け Worksheets(“貼付シート”).Range("B15", "B43", "B71", "B99", "B127", "B155", "B183").Select Selection.PasteSpecial Paste:=xlPasteFormulas '←5個の値をコピー Worksheets("“コピー元シート”").Range("B11").Select Selection.Copy '←貼付け Worksheets(“貼付シート”).Range("B17", "B45", "B73", "B101", "B129", "B157", "B185").Select Selection.PasteSpecial Paste:=xlPasteFormulas End Sub

  • 印刷後のVBAの実行(4)

    Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = "顧客データー1" Then If Range("D1").Value = "" Then Cancel = True MsgBox ("名前を入力してください") Range("D1").Select Exit Sub End If Else Exit Sub End If End If If Worksheets("顧客データー1").Range("D6") = "不可" Or _ Worksheets("顧客データー2").Range("D6") = "不可" Then GoTo P1 ActiveSheet.Range("F650:O650").Copy If Worksheets("日報").Range("F5").Value = "" Then Worksheets("日報").Range("F5").PasteSpecial Paste:=xlPasteValues Else Worksheets("日報").Range("F65536").End(xlUp).Offset(1, 0).PasteSpecial _ Paste:=xlPasteValues End If Application.CutCopyMode = False P1: ActiveSheet.Range("A1").Select End Sub 現在上記コードを使っていますが、ワークシート日報への値のみ貼り付けの部分で少し変更したいのですが、印刷するシートのセルM1の値が1ならそのシートのRangeF650:O650をコピーしてワークシート日報のF5に値のみで貼り付け、M1の値が2ならF6に、M1の値が3ならF7に・・・という感じでM1の数字の値によってワークシート日報へ貼り付け先を変えていくようしたいのですが、どのようにコードを変更したらいいでしょうか?

  • Excel2007 VBA 転記について

    ご指導のほどお願いします。 見積書からボタン300をクリックするとFAX送付状(テンプレート).xlsに下記内容が転記するように書いたのですが、質問させてください。 ("見積書").Range("c6")→("Sheet1").Range("e14")に貼り付けはうまく行きますが 本当は("見積書").Range("c6")&("見積書").Range("c8")=&"の件"を("Sheet1").Range("e14")に貼り付けしたいのです。 C6セル「○○○工場」 C8セル「○○○作業」 の件 ↑をE14セルに「○○○工場 ○○○作業の件」 として貼り付けたいです。 Sub ボタン300_Click() Workbooks.Open "\FAX送付状\FAX送付状(テンプレート).xls" ThisWorkbook.Worksheets("見積書").Range("a4").Copy Workbooks("FAX送付状(テンプレート).xls").Worksheets("Sheet1").Range("f6").PasteSpecial Paste:=xlPasteValues ThisWorkbook.Worksheets("見積書").Range("i8").Copy Workbooks("FAX送付状(テンプレート).xls").Worksheets("Sheet1").Range("AD9").PasteSpecial Paste:=xlPasteValues ThisWorkbook.Worksheets("見積書").Range("c6").Copy Workbooks("FAX送付状(テンプレート).xls").Worksheets("Sheet1").Range("e14").PasteSpecial Paste:=xlPasteValues  ActiveSheet.Range("F9").Value = Date End Sub ご指導のほどお願いします。

  • シート1のC列の最終行をコピーして同じ行に値貼り付けしたい

    シート1のC列の最終行を取得して その行を丸々値貼り付けするマクロを作りたいと思います。 シート3のB18の値をシート1のC列の最終行の1つ下のセルに値貼り付け すると、その行のA、B列に日付が入力される関数が入っています。(下まで) 関数が入ったままだと、うまくいかない時があるので最終行をコピーして値貼り付けしたいのですが、マクロの作り方を教えてください。 シート1の最終行に貼り付け Sheets("Sheet3").Select Range("B18").Select Selection.Copy Sheets("Sheet1").Select Range("C65536").End(xlUp).Offset(1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False End Sub 最終行をコピーして値貼り付け Dim 最終行 As Integer 最終行 = Range("C65536").End(xlUp).Row Range("A6:C" & 最終行).Select Selection.Copy Sheets("Sheet1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False End Sub このマクロだと、A6からC列の最終行まで全てコピーされてしまうので、C列の最終行のAからC列まで1行だけコピーできないでしょうか?

  • 複数シートの一定範囲を、他シートの表に貼り付けたい

    Win7 Excel2007 でマクロ作成中の初心者です。 複数シートの一定の範囲を、総括表シートの中にある表に貼り付けたいです。 いろいろサイト探しましたが方法がわかりません。どうかご教示おねがいします。 Sub 総括表シートに貼り付け() ' Dim list, sheetName Application.ScreenUpdating = False Const EXCEPT_NAME = "総括表 保管用" For Each sheetName In ActiveWorkbook.Worksheets If InStr(EXCEPT_NAME, sheetName.Name) = 0 Then Sheets(sheetName.Name).Activate ActiveSheet.Unprotect   複貼り付け用部品 ActiveSheet.Protect End If Next End Sub -------------------------------------------- Sub 複貼り付け用部品() ’自動記録のコード 'すべてのシートの Range("AW7:AW34")の範囲を総括表シートに貼り付け '貼り付け位置は、総括表のシートのD列からに順番に貼り付け ActiveSheet.Unprotect Range("AW7:AW34").Select '最初のシート Selection.Copy Range("D4:D31").Select '総括表シートのD列に貼り付け Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("AW7:AW34").Select '2番目のシート Application.CutCopyMode = False Selection.Copy Range("E4:E31").Select '総括表シートのE列に貼り付け Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("AW7:AW34").Select '3番目のシート Application.CutCopyMode = False Selection.Copy Range("F4:F31").Select '総括表シートのF列に貼り付け Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("AW7:AW34").Select '4番目のシート Application.CutCopyMode = False Selection.Copy Range("G4:G31").Select '総括表シートのG列に貼り付け Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '以下続く End Sub

  • エクセルVBAで書式と値の貼付けにつて

    エクセル2007VBAで新規ファイルを作る場合のコピー、貼り付けで質問しましたが 式も全て貼り付けになるとUSBメモリーで持ち出した場合、エラーとなります。 それで値と書式のみ貼り付けする様下記の様に書き直しましたが、.PasteSpecialでメソッドまたはデータメンバーが見つかりませんとなります。 ぐぐっててヘルプを見ますが解決出来ません。どなたがご教授お願いします。 元の式 Sub DGCopy() Workbooks.Add With ThisWorkbook .Sheets(5).Cells.Copy Sheets(1).Cells Sheets(1).Select Sheets("Sheet1").Name = "電気代" .Sheets(6).Cells.Copy Sheets(2).Cells Sheets(2).Select Sheets("Sheet2").Name = "ガス代" F = Application.GetSaveAsFilename(FileFilter:="Excelブック (*.xls),*.xls)") If F = "False" Then Exit Sub ' ダイアログでCancelをクリックした場合 ActiveWorkbook.SaveAs Filename:=CStr(F) End With End Sub 書き直した式 Sub DGCopy() Workbooks.Add With ThisWorkbook Sheets(5).Select Cells.Selection.Copy Sheets(1).Selection .PasteSpecial Paste:=xlPasteFormats ←エラー部分 .PasteSpecial Paste:=xlPasteValues Sheets("sheets1").Name = "電気代" Sheets(6).Select Cells.Selection.Copy Sheets(2).Selection .PasteSpecial Paste:=xlPasteFormats .PasteSpecial Paste:=xlPasteValues Sheets("sheets2").Name = "ガス代" F = Application.GetSaveAsFilename(FileFilter:="Excelブック (*.xls),*.xls)") If F = "False" Then Exit Sub ActiveWorkbook.SaveAs Filename:=CStr(F) End With End Sub

専門家に質問してみよう