VBAで複数シートを新たに作成したBookにコピー

質問

いつも大変お世話になります。動作環境は、WindowXPSP3、EXCEL2010です。10個の名前付きsheetがあります。Book.xlsmから新たにBook1.xlsxを作成してこのBook1.xlsxに1個のsheet名が「sheet1」を作成します。そして、Book.xlsmにある10個の名前付きsheetをBook1.xlsxに作成した一個のsheet1にコピーします。コピーの仕方は、Book.xlsmの一番左端のsheetから順番にBook1.xlsxに作成した1個のsheet1に下から上に向かってコピーしていきます。最終的には、10個の名前付きsheetが纏められます。後一つの条件は、一番最初にコピーするシートには4行目に項目書かれております。なので、一番最初にコピー4行目だけはコピーして、後は、5行目からコピーしたく、下記のマクロを作成しました。

Option Explicit
Option Base 1
Public Sub シートの纏め()
Dim i As Long
Dim mySheetCnt As Long
Dim mySheetName() As String
Dim ws As Workbook
Dim s As Worksheet
'==========================================================================
mySheetCnt = ThisWorkbook.Sheets.count
ReDim mySheetName(1 To mySheetCnt)
For i = 1 To mySheetCnt - 3
mySheetName(i) = Sheets(i).Name
'MsgBox "変数mySheetName(" & i & ")=" & mySheetName(i)
Next i
'==========================================================================
Dim EffectiveRow As Long
Dim EffectiveColumn As Long
EffectiveRow = Range("B65536").End(xlUp).Row
'MsgBox "EffectiveRow = " & EffectiveRow & ""
EffectiveColumn = Cells(4, 256).End(xlToLeft).Column
'MsgBox "EffectiveColumn = " & EffectiveColumn & ""
'==========================================================================
Dim Book1 As Workbook
For i = 1 To mySheetCnt - 3
If mySheetCnt = 11 Then GoTo Label1
'MsgBox "mySheetName(i) = " & mySheetName(i) & ""
'MsgBox "デフォルトで" & Application.SheetsInNewWorkbook & "枚作成されます"
Workbooks.Add
Application.SheetsInNewWorkbook = 1
Sheets("sheet1").Select
Book1 = ActiveWorkbook.Name
Workbooks("Bookxlsm").Worksheets("mySheetName(i)").Range("B4:AF58").Copy _　　
Workbooks("Book1.xls").Worksheets("sheet1").Range("B4") ⇐ここで、実行時エラーが出ます。
Next i
Label1:
End Sub

しかし、実行時エラーで止まってしまいます。もう、1週間格闘しております。どなたか、何卒ご教授して頂きたく、宜しくお願い申し上げます。

回答No.1

keithin · ベストアンサー

何度も同じご相談を投稿して、回答をもらっても返事もせずに放っぽり出して、よく飽きずに繰り返しますね。

＞一番最初にコピー4行目だけはコピーして、後は、5行目からコピーしたく

そのたびにコピーしたい範囲が変わったりとか、ご愛嬌ですけど。

んーと？
今回新しく加わったヤリタイ事は、

＞下から上に向かってコピーしていきます
の部分だけですね。

sub macro3()
　dim i as long
　worksheets(1).copy before:=worksheets(1)
　for i = 3 to 12
　　worksheets(i).range("5:58").copy
　　worksheets(1).range("5:5").insert
　next i
　worksheets(1).move
　activesheet.name = "sheet1"
　activeworkbook.saveas filename:="Book1.xlsx", fileformat:=xlopenxmlworkbook
end sub

お礼

初めまして、皆さんのご回答有難う御座ます。皆さんから寄せらたご回答を参考にさて頂き何とかこの問題を解決す事が出来ました。今後とも宜しくお願い申し上げます。

回答No.2

keithin

ちょっと間違いました

sub macro3()
　dim i as long
　worksheets(1).copy before:=worksheets(1)
　for i = 3 to 11
　　worksheets(i).range("5:58").copy
　　worksheets(1).range("5:5").insert
　next i
　worksheets(1).move
　activesheet.name = "sheet1"
　activeworkbook.saveas filename:="Book1.xlsx", fileformat:=xlopenxmlworkbook
end sub

失礼しました。

お礼

本当に有難う御座いました。ご自身の間違いを正して頂き本当に有難う御座います。これを参考ににして別の方法で解決できました。これからも宜しお願いもう脚仕上げます。