新たなワークシートへのコピペVBA

質問

（１）Excelの一つのBOOKの中に複数のワークシートがあります。

（２）これらワークシートの中から、任意でいくつかのみを選びます。

（３）新たなワークシートを一つ作り、ここに、（２）で選んだワークシートを順番に横並びでコペピする。

上記をVBAで自動化させるには、どうしたらよろしいのですか？

回答No.1

cj_mover

こんにちは。

下記コードを当該ブックの標準モジュールに貼り付けてから、
Sub CrPickUpSh8318367()を実行。
後は指示通りに、
　【任意】のシートを選択して、
　実行ボタンを押し、
　シート名を指定するだけ。
シーケンシャルなＵＩ形式です。

＃【任意】という言葉、の意味が合っている前提でお応えしています。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub CrPickUpSh8318367()　　'　　プロシージャ名は自由の変更可。
　　Dim oWshts As Worksheets
　　Dim tnWsht As Long
　　Dim i As Long
　　With Worksheets
　　　　tnWsht = .Count
　　　　With .Add(After:=.Item(tnWsht))
　　　　　　.Name = "PickUpSheets"
　　　　　　For i = 1 To tnWsht
　　　　　　　　With .OLEObjects.Add(ClassType:="Forms.CheckBox.1", Left:=1, Top:=Cells(i, 1).Top, Width:=100, Height:=18)
　　　　　　　　　　.Object.Caption = Worksheets(i).Name
　　　　　　　　End With
　　　　　　　　With .Buttons.Add(144, 0, 72, 72)
　　　　　　　　　　.OnAction = "ShMerge"
　　　　　　　　　　.Caption = "シートの結合／実行"
　　　　　　　　End With
　　　　　　Next i
　　　　End With
　　End With
　　MsgBox "結合させたいシート名にチェックを入れて、実行ボタン。", , "シートの結合／シート選択"
End Sub
' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub ShMerge()　　'　　プロシージャ名は変更不可。
　　Dim arrShName() As String
　　Dim oOle As OLEObject
　　Dim oShape As Shape
　　Dim sBuf As String
　　Dim sName As String
　　Dim nPrCol As Long
　　Dim i As Long

　　With Sheets("PickUpSheets")
　　　　For Each oOle In .OLEObjects
　　　　　　If TypeName(oOle.Object) = "CheckBox" Then
　　　　　　　　If oOle.Object.Value = True Then sBuf = sBuf & vbLf & oOle.Object.Caption
　　　　　　End If
　　　　Next
　　　　If sBuf = "" Then
　　　　　　MsgBox "結合するシートが選択されていません。", , "シートの結合／シート選択"
　　　　　　Exit Sub
　　　　End If

　　　　For Each oShape In .Shapes
　　　　　　oShape.Delete
　　　　Next

　　　　arrShName() = Split(sBuf, vbLf)
　　　　For i = 1 To UBound(arrShName())
　　　　　　With .UsedRange
　　　　　　　　nPrCol = .Cells(.Cells.Count).Column + 1
　　　　　　End With
　　　　　　Worksheets(arrShName(i)).UsedRange.Copy _
　　　　　　　　Destination:=.Cells(nPrCol)
　　　　Next i

　　　　Do
　　　　　　sName = Application.InputBox(Prompt:="シートの結合／完了" & vbLf & "シート名を指定", _
　　　　　　　　　　　　　　　　　　　　Title:="シートの結合／シート名を指定", _
　　　　　　　　　　　　　　　　　　　　Default:="結合Sheet", Type:=2)
　　　　　　Select Case sName
　　　　　　Case "", "False"
　　　　　　Case Else
　　　　　　　　.Name = sName
　　　　　　　　Exit Do
　　　　　　End Select
　　　　Loop
　　End With
End Sub
' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝