こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

Excel VBAでシートを別なBookにするには?

Book ABC.xls の Sheet("TEST") を書式と値(数式でなく)だけコピーし別なBookとして保存したいのです。
その際、Sheets("LOGIC").Range("A1")を、マクロで1回目は2、2回目は3とし、12回目の13まで行います。Sheets("TEST")はSheets("LOGIC").Range("A1")を参照しているので、その結果として、Sheets("TEST")の値は当然12通りに変化します。
新たに自動作成される別なBookは Sheet1~Sheet12の12枚のシートをもち、それぞれがABC.xls の Sheets("TEST") の12通りのコピーとなるようにしたいのです。
このようなマクロはどう作ればいいのでしょうか?
お手上げです。何卒よろしくお願いします。

投稿日時 - 2003-01-30 01:57:41

QNo.459022

困ってます

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

こんにちは。
こんな感じでしょうか?

Sub Test()
Dim wb As Workbook , wsCount As Integer
Application.ScreenUpdating = 0
wsCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 12
Set wb = Workbooks.Add
Application.SheetsInNewWorkbook = wsCount
 With ThisWorkbook.Worksheets("LOGIC")
  For i = 1 To 12
   .Range("A1").Value = i + 1
   ThisWorkbook.Worksheets("TEST").Cells.Copy
   wb.Worksheets(i).Cells.PasteSpecial Paste:=xlValues
   wb.Worksheets(i).Cells.PasteSpecial Paste:=xlFormats
  Next i
 End With
Application.CutCopyMode = 0
End Sub

投稿日時 - 2003-01-30 08:23:43

お礼

朝早くからご回答ありがとうございました。
おかげでなんとか思った物が作れました!ほんとうに助かりました。
ところで、昨夜一つ書き漏れがあったことに気づきました。
新しいbookの12枚のシートはすべて「値」が入っているわけですが、全部のシートのAF38のセルだけには数式を入れなければならなかったのです。
数式は非常に長く、以下の通りです。

=TEXT(IF(AF23="",0,SUBSTITUTE(AF23," ",""))+IF(AF24="",0,SUBSTITUTE(AF24," ",""))+IF(AF25="",0,SUBSTITUTE(AF25," ",""))+IF(AF26="",0,SUBSTITUTE(AF26," ",""))+IF(AF27="",0,SUBSTITUTE(AF27," ",""))+IF(AF28="",0,SUBSTITUTE(AF28," ",""))+IF(AF29="",0,SUBSTITUTE(AF29," ",""))+IF(AF30="",0,SUBSTITUTE(AF30," ",""))+IF(AF31="",0,SUBSTITUTE(AF31," ",""))+IF(AF32="",0,SUBSTITUTE(AF32," ",""))+IF(AF33="",0,SUBSTITUTE(AF33," ",""))+IF(AF34="",0,SUBSTITUTE(AF34," ",""))+IF(AF35="",0,SUBSTITUTE(AF35," ",""))+IF(AF36="",0,SUBSTITUTE(AF36," ",""))+IF(AF37="",0,SUBSTITUTE(AF37," ","")),"# # # # # # #")

どのように教えていただいたマクロに書き加えればいいでしょうか?
また、この数式自体も簡略化する方法がもしあれば教えてください。

投稿日時 - 2003-01-30 16:32:08

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.4

再びこんにちは。

wb.Worksheets(i).Cells.PasteSpecial Paste:=xlFormats の下に
下記の(1)か(2)のどちらかを加えれば良いと思います。

'(1) TEST シートのもと数式をコピー
ThisWorkbook.Worksheets("TEST").Range("AF38").Copy _
 Destination:=wb.Worksheets(i).Range("AF38")

'(2) 多分同じ値が返ると思う配列数式
wb.Worksheets(i).Range("AF38").FormulaArray = _
 "=TEXT(SUM(IF(AF23:AF37="""",0,SUBSTITUTE(AF23:AF37,"" "",""""))*" & _
 "(IF(AF23:AF37<>"""",1,0))),""# # # # # # #"")"

投稿日時 - 2003-01-30 21:41:19

お礼

うーん!凄い!!凄すぎる!!!!
完璧です。ありがとうございました。

投稿日時 - 2003-01-31 13:06:05

ANo.3

Sheetが、左から右へ並ぶようにこだわってみました。


Sub ABC_TEST_COPY()
Dim NEWWORKBOOK As Workbook
Dim LOGICCELL As Range
Dim TESTCELL As Range
Dim LOOPCOUNT As Integer

'新規ブック作成及びSheet1からSheet12を作成
Set NEWWORKBOOK = Workbooks.Add
Do While NEWWORKBOOK.Worksheets.Count < 12
NEWWORKBOOK.Worksheets.Add
Loop
For LOOPCOUNT = 2 To 12
NEWWORKBOOK.Worksheets("Sheet" & LOOPCOUNT).Move after:= _
NEWWORKBOOK.Worksheets("Sheet" & LOOPCOUNT - 1)
Next LOOPCOUNT

'コピー処理
Set LOGICCELL = Workbooks("ABC.XLS").Worksheets("LOGIC").Cells(1, 1)
Set TESTCELL = Workbooks("ABC.XLS").Worksheets("TEST").Cells
For LOOPCOUNT = 1 To 12 Step 1
'Sheets("LOGIC").Range("A1")に値を入力
LOGICCELL.Value = LOOPCOUNT + 1
TESTCELL.Copy
'書式貼付
NEWWORKBOOK.Worksheets("Sheet" & LOOPCOUNT).Cells.PasteSpecial Paste:=xlFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'値貼付
NEWWORKBOOK.Worksheets("Sheet" & LOOPCOUNT).Cells.PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next LOOPCOUNT

MsgBox ("END")
End Sub

投稿日時 - 2003-01-30 12:11:01

お礼

ありがとうございました。いろいろな方法があるんですね。
勉強させていただきます。

投稿日時 - 2003-01-31 13:33:01

ANo.2

ロジックは、ブックABC.xlsを読み込んで、その中の1つのシートTESTをコピーし、コピー先シートの名を設定し、A1だけ変化させ、別ブック名で保存しました。私のテストのため勝手ながら
ABC.xls--->c:\my documents\aa1.xls"
12枚------>4枚
新ブック名----->aa11.xlsになっています。
変更してください。
(ABC.xlsのTEST以外のシートも新ブックに残りますが、あるのかどうか不明ですし、手を打っていません。)
Sub test01()
Workbooks.Open "c:\my documents\aa1.xls"
For i = 1 To 3
sn = "LOGIC" & Trim(Str(i + 1))
MsgBox sn
Workbooks("aa1.xls").Sheets.Add.Name = sn
Worksheets("TEST").Cells.Copy
Sheets(sn).Cells.Select
ActiveSheet.Paste
Sheets(sn).Range("a1") = i + 1
Next i
Worksheets("TEST").Name = "LOGIC1"
ActiveWorkbook.SaveAs "c:\my documents\aa11.xls"
End Sub
---------
>Sheets("LOGIC").Range("A1")を・・・
LOGICが突然出てきて戸惑いました。新ブックの
シート名の1つですよね。
>Sheets("TEST")の値は当然12通りに変化します。
どの様に変化させるか、不明ですから番号数を1ずつ
アップしておきました。適当なプログラムステップで
置換えてください。

投稿日時 - 2003-01-30 12:00:59

お礼

ありがとうございました。
勉強させていただきます。

投稿日時 - 2003-01-31 13:32:15

あなたにオススメの質問