右隣りのシートの文末にコピーして貼り付ける
Part1
Sub アクティブシートの表を右隣のシートの文末に貼り付ける()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
' アクティブなシートを取得
Set sourceSheet = ActiveSheet
' 右隣のシートを取得
Set targetSheet = sourceSheet.Next
' コピー元の範囲を取得
Dim lastRow As Long
Dim lastColumn As Long
lastRow = sourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastColumn = sourceSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set sourceRange = sourceSheet.Range("A1", Cells(lastRow, lastColumn))
' 貼り付け先の範囲を取得
Dim targetRow As Long
targetRow = targetSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
Set targetRange = targetSheet.Range("A" & targetRow)
' コピー元の範囲をコピーして、貼り付け先の範囲に貼り付ける
sourceRange.Copy
targetRange.PasteSpecial xlPasteValuesAndNumberFormats
' コピーした内容を元シートから削除する
sourceRange.Delete xlShiftUp
MsgBox "貼り付けました。"
End Sub
この例では、ActiveSheet
プロパティでアクティブなシートを取得し、Next
プロパティで右隣のシートを取得しています。コピー元の範囲は、Range
オブジェクトを使用して取得し、貼り付け先の範囲は、貼り付ける前に取得しています。Copy
メソッドでコピー元の範囲をコピーし、PasteSpecial
メソッドで貼り付け先の範囲に貼り付けています。また、貼り付けた内容を元シートから削除しています。
Part2
このコードは、アクティブシートの表を右隣のシートの文末にコピーして貼り付け、その後、新しいシート名を “output” に変更し、ファイルを保存します。
Sub 右隣りのシートの文末にコピーして貼り付け()
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.ActiveSheet
Dim LastRow1 As Long
LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol1 As Long
LastCol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
Dim MyCell As Range
Set MyCell = ws1.Range("A1", Cells(LastRow1, LastCol1))
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.ActiveSheet.Next
Dim LastRow2 As Long
LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
'---------------------------------------
MyCell.SpecialCells(xlCellTypeVisible).Copy _
Destination:=rng
rng.EntireRow.Delete Shift:=xlUp ’一行目を削除
'---------------------------------------
'シート名変更--------------------------
ActiveSheet.Next.Activate
Dim Num As Long
On Error Resume Next
ActiveSheet.Name = "output"
Do
If Err.Number = 0 Then Exit Do
Err.Clear
Num = Num + 1
ActiveSheet.Name = "output" & "_" & Num
Loop
'---------------------------------------
Application.CutCopyMode = False
ActiveWorkbook.Save
'メッセージボックスで行数確認
MsgBox "完了" & vbLf & vbLf & "基=" & LastRow1 - 1 & vbLf & "先=" & LastRow2 & vbLf & "確認=" & LastRow1 - 1 + LastRow2
End Sub
1行目:サブルーチンの開始。
3-7行目:ws1にアクティブシートを設定し、LastRow1とLastCol1にアクティブシートの最終行と最終列を設定します。MyCellに、アクティブシートの全範囲を設定します。
9-13行目:ws2に、アクティブシートの右隣のシートを設定します。LastRow2に、右隣のシートの最終行を設定します。rngに、右隣のシートで次に使用可能なセルを設定します。
16-19行目:アクティブシートの表示されているすべてのセルをMyCellからコピーして、右隣のシートのrngに貼り付けます。一行目を削除します。
22-30行目:新しいシート名を “output” に変更し、変更したシート名がすでに存在する場合は、番号を追加して名前を変更します。
33-35行目:カットコピー操作を解除します。
36-37行目:ファイルを保存します。
40-43行目:メッセージボックスに、コピー元とコピー先の行数を表示します。
44行目:サブルーチンの終了。
コメント