質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

2回答

2007閲覧

VBA シートコピー作成後指定枚数でファイル分割したい

cat_junko

総合スコア44

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2016/07/22 14:38

いつも大変お世話になっております。
下記の、シートコピーのコードを書きました。
コピーシート数は、32枚~最大130枚まであります、
130枚コピーすると色々大変なのと重くなるので2分割
したいと思っているのですがシートごとに1ファイルと言うのは
検索すると出てくるのですが指定シート枚数で分割というやり方
が分かりません。
ご教示願います。

'現在アクティブなシートの後ろにコピーする Sub タイプ別シート作成() Dim TYPE1, TYPE2 Dim sh_name Dim 鋼矢板No Dim TypeNo Dim sh1, sh4 Set sh1 = Worksheets("入力シート") Set sh4 = Worksheets("作業準備") 鋼矢板No = 3 TypeNo = 3 For TypeNo = 3 To sh1.Range("A65536").End(xlUp).Row If sh1.Cells(TypeNo, 2) = sh4.Range("K10") Then '奇数No Worksheets(sh4.Range("J10") & sh4.Range("K10")).Copy After:=Worksheets(鋼矢板No + 3) 'シート名変更 sh_name = sh1.Cells(鋼矢板No, 1) ActiveSheet.Name = sh_name 'シート名にTYPE追記 ActiveSheet.Tab.ColorIndex = 4 ActiveSheet.Range("G5") = sh_name 鋼矢板No = 鋼矢板No + 1 ElseIf sh1.Cells(TypeNo, 2) = sh4.Range("K11") Then '偶数No Worksheets(sh4.Range("J11") & sh4.Range("K11")).Copy After:=Worksheets(鋼矢板No + 3) 'シート名変更 sh_name = sh1.Cells(鋼矢板No, 1) ActiveSheet.Name = sh_name '& "②" 'シート名にTYPE追記 ActiveSheet.Tab.ColorIndex = 4 ActiveSheet.Range("G5") = sh_name 鋼矢板No = 鋼矢板No + 1 End If Next MsgBox "シート作成完了しました!" End Sub

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答2

0

ベストアンサー

こうですか。動きますか。違いますか。

Sub タイプ別シート作成() Dim frombook set frombook = ActiveWorkbook Dim sh_name Dim 鋼矢板No Dim TypeNo Dim sh1, sh4 Set sh1 = frombook.Worksheets("入力シート") Set sh4 = frombook.Worksheets("作業準備") 鋼矢板No = 3 TypeNo = 3 Dim tobook Dim sh_count sh_count = 65 ' 130 の半分 For TypeNo = 3 To sh1.Range("A65536").End(xlUp).Row If sh1.Cells(TypeNo, 2) = sh4.Range("K10") Then '奇数No if TypeNo = 3 then frombook.Worksheets(sh4.Range("J11") & sh4.Range("K11")).Copy set tobook = activeworkbook elseif ((TypeNo - 3) mod sh_count) = 0 then ' 必要があれば tobook.saveAs すること frombook.Worksheets(sh4.Range("J11") & sh4.Range("K11")).Copy set tobook = activeworkbook else frombook.Worksheets(sh4.Range("J10") & sh4.Range("K10")).Copy After:=tobook.Worksheets(tobook.worksheets.count) end if 'シート名変更 sh_name = sh1.Cells(鋼矢板No, 1) ActiveSheet.Name = sh_name 'シート名にTYPE追記 ActiveSheet.Tab.ColorIndex = 4 ActiveSheet.Range("G5") = sh_name 鋼矢板No = 鋼矢板No + 1 ElseIf sh1.Cells(TypeNo, 2) = sh4.Range("K11") Then '偶数No if TypeNo = 3 then frombook.Worksheets(sh4.Range("J11") & sh4.Range("K11")).Copy set tobook = activeworkbook elseif ((TypeNo - 3) mod sh_count) = 0 then ' 必要があれば tobook.saveAs すること frombook.Worksheets(sh4.Range("J11") & sh4.Range("K11")).Copy set tobook = activeworkbook else frombook.Worksheets(sh4.Range("J11") & sh4.Range("K11")).Copy After:=tobook.Worksheets(tobook.worksheets.count) end if 'シート名変更 sh_name = sh1.Cells(鋼矢板No, 1) ActiveSheet.Name = sh_name '& "②" 'シート名にTYPE追記 ActiveSheet.Tab.ColorIndex = 4 ActiveSheet.Range("G5") = sh_name 鋼矢板No = 鋼矢板No + 1 End If Next MsgBox "シート作成完了しました!" End Sub

投稿2016/07/23 15:45

asterisk9101

総合スコア49

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

cat_junko

2016/07/25 12:57

返信が、大変遅くなり申し訳ありません、 上記のコードで、動きました。 データ転記等のコードを、書き換えて完全に完成させたいと思います。 ありがとうございました。
guest

0

全部スクリプトでやるのではなく、手作業も取り混ぜたら簡単になりそうな気がします。

  • オリジナルのファイルを手作業でファイルコピーし、後半のシートを削除し、前半のみのファイルを作成
  • 再度オリジナルのファイルを手作業でファイルコピーし、前半のシートを削除し、後半のみのファイルを作成

といった感じでやったらどうでしょう。
継続的にこの作業を行う予定があるのなら、手作業の部分をバッチファイル化するとか、WSHで処理するなど、手段は色々あります。

投稿2016/07/23 02:51

tohshima

総合スコア374

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

cat_junko

2016/07/25 13:03

返信が、遅くなり大変申し訳ありませんでした。 そうですよね、何でも自動化すればいいわけではないですよね。 使用頻度に、合わせて使い分けたいと思います。 ただ、今回は勉強の為にどうすれば分割に出来るのかを考えることが出来たので どちらの回答も勉強になりました。 今後の勉強の為、コードは書き直してみようと思いますが頻度としては少ないので 上記の方法になりそうです。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問