至急お願いします。エクセルのマクロに関してです。

質問

かなり至急です＞＜エクセル2010のマクロの質問です。
2つ質問があります。

1つ目です。
以下の一連の作業を1つのマクロで行いたいのですが、どうしたらいいでしょうか？
現在は、シート1にデータがあります。
(1)選択した3列を、B~D列に移動する
(2)B列に含まれるセルのうち、0（空白）でないセル数分だけシートを追加する。
(たとえば、シート1のB14~B18に数字がはいっていたら、シートを5枚追加するという感じです。)
(3)B列に含まれるセルのうち、0（空白）でないセル数分に対し、2行ずつ各シートの3・4行目にコピーする。
(たとえば、シート1のB14~B18に数字がはいっていたら、シート2の3・4行にシート1の14・15行のコピーを貼り付け、シート3の3・4行にシート1の15・16行のコピーを貼り付け、シート4の3・4行にシート1の16・17行のコピーの貼り付ける・・・という感じです。)
現在は
(1)Sub ()
Selection.Cut
ActiveCell.Columns("A:C").EntireColumn.Select
Selection.Cut
Columns("B:B").EntireColumn.Select
Selection.Insert Shift:=xlToRight
End Sub
(2)
Sub Macro()
Dim n As Long
For n = 14 To 18 '
Sheets.Add
Next
End Sub
(3)
Sub Macro()
Dim n As Long
For n = 14 To 18 '
Sheets("Sheet1").Rows(n & ":" & n + 1).Copy _
Sheets("Sheet" & n - 252).Range("A3")
Next
End Sub
と別々のマクロに分けてます。
また(2)(3)でみられる
For n = 14 To 18 '
の部分の数字は手動でいれてますが、かなり時間をくってしまうので・・・。

2つ目です。
複数ブックに同じ動作をするエクセルのマクロが知りたいです。
現在100ほどブック(Book1~100)を開いていて、100のブックすべてのSheet1のA1のセルに「１」と入れたいのですが、
そのようなマクロはどうくんだらよろしいでしょうか。
ちなみにExcel2007です。

困っているので、お願いします。

回答No.1

DOUGLAS_

＞かなり至急です＞＜エクセル2010のマクロの質問です。
＞ちなみにExcel2007です。
随分と急いでいらっしゃるようですね。　　(≧ε≦)ノ彡

＞(1)選択した3列を、B~D列に移動する
　どのように選択しているのか判りませんので、とりあえず、移動後にＢ列になるべき列内に「ActiveCell」があることを条件としてスタートします。

＞0（空白）でない
　「0でない」のか「空白でない」のかによって操作が異なります。
　「空白でない」場合は、「Value <> 0」を「Value <> ""」にしてください。

＞たとえば、シート1のB14~B18に数字がはいっていたら
　「0（空白）でない」のか「数字がはいっていたら」なのか、これもはっきりしていただいた方がよいですね。
　「数字がはいっていたら」の場合は、「Range("B" & n).Value <> 0」を
Len(Range("B" & n).Value) * IsNumeric(Range("B" & n).Value) <> 0
にでも替えてください。

＞(たとえば、シート1のB14~B18に数字がはいっていたら、
＞シートを5枚追加するという感じです。)
＞(3)B列に含まれるセルのうち、0（空白）でないセル数分に対し、
＞2行ずつ各シートの3・4行目にコピーする。
とのことですが、
１枚目＝１・２行目
２枚目＝２・３行目
３枚目＝３・４行目
４枚目＝４・５行目
となり「５枚目」が「５行目」だけになるようですので、「0（空白）でないセル数分」から「1」を引いた数だけシートを増やすようにしています。

　「0（空白）でないセル」が連続しているかどうかが判りませんでしたので、１行ずつコピーするようにしてあります。
　そのため、「0（空白）でないセル」のセル番地を「myAdd」という配列に入れ、１つずつ操作をするようにしました。

Sub Macro1()
　　Dim n As Long
　　Dim myAdd As Variant
　　ActiveCell.Columns("A:C").EntireColumn.Cut
　　Range("B1").Insert xlToRight
　　For n = 1 To Range("B" & Rows.Count).End(xlUp).Row
　　　　If Range("B" & n).Value <> 0 Then myAdd = myAdd & " " & Range("B" & n).Address
　　Next
　　myAdd = Split(Trim(myAdd))
　　For n = 0 To UBound(myAdd) - 1
　　　　Sheets.Add after:=ActiveSheet
　　　　Sheets("Sheet1").Range(myAdd(n)).EntireRow.Copy Range("A3")
　　　　Sheets("Sheet1").Range(myAdd(n + 1)).EntireRow.Copy Range("A4")
　　Next
End Sub

　２つ目のご質問は、ざっと、こんな感じでいかがでしょうか？

Sub Macro2()
　　Dim myWB As Workbook
　　For Each myWB In Workbooks
　　　　myWB.Activate
　　　　Sheets("Sheet1").Select
'複数ブックに同じ動作
　　　　Range("A1").Value = 1
　　Next
End Sub