VBA Copy row and insert copy of row below into active sheet and insert row into another sheet

[M4TVD]

Hello,

I have a workbook that I already have a large amount of VBA code in, running a multitude of functions. One of these is to copy the data in row that contains the active cell and insert a row with this data into the row below. I need to add to this code to insert a row (must be the same row as being inserted into the active sheet) into another sheet in the same workbook.

For example if I have cell D175 as active cell, I click the button with the assigned VBA code, it copy's row 175 and inserts a new row into row 176 that contains the same data as row 175.

I require code adding that will also add the same row number into another sheet (call this "Build Output")

This is my current code:

Sub InsertCopyOfPart()
   With ActiveCell
      .Offset(1).EntireRow.Insert
      Cells(.Row, 1).Resize(2, 13).FillDown
            
   End With
End Sub

 

[My Aswer Is This]

Try this:

Sub InsertCopyOfPart()
'Modified  11/21/2021  1:50:14 PM  EST
Dim Lastrow As Long
Dim c As Long
c = ActiveCell.Column
Dim r As Long
r = ActiveCell.Row
Lastrow = Sheets("Build Output").Cells(Rows.Count, c).End(xlUp).Row
   
   
   With ActiveCell
      .Offset(1).EntireRow.Insert
      Cells(.Row, 1).Resize(2, 13).FillDown
            Rows(r).Copy Sheets("Build Output").Rows(Lastrow + 1)
   End With
Rows(r).Copy Sheets("Build Output").Rows(Lastrow + 1)

Application.ScreenUpdating = True
End Sub

 

[M4TVD]

Thankyou,

This does not do what I require as it only inserts a copy of the selected row into the bottom row of sheet "Build Output". I require it to insert a new (blank row) into the "Build Output" sheet as it is inserting into the active sheet.


I have this code also within my workbook that will remove a row from the active sheet ( in this case "ALL PARTS") cut and paste it into a different sheet in the workbook and then also delete the row (same as active row) from the "build Output Sheet". Can Any of this code be re-used to insert row instead of delete row?

Sub DeadPart()
Dim Answer As String
Dim x As Long
Dim i As Long

i = ActiveCell.Row

ActiveCell.EntireRow.Cut

Answer = MsgBox("Are you sure you want to remove this part from circulation?", vbYesNo, "Dead Part?")
If Answer = vbNo Then

MsgBox "Nothing Removed"
End

Else
Sheets("Quarantine").Select
x = Range("K" & Rows.Count).End(xlUp).Row
x = x + 1
Cells(x, 1).Select
Selection.Insert Shift:=xlDown
Sheets("Build Output").Select
Rows(i).EntireRow.Delete
Sheets("Build Output (SPARE)").Select
Rows(i).EntireRow.Delete
Sheets("ALL PARTS").Select
Rows(i).EntireRow.Delete


MsgBox "Part Removed from Circulation - Now in Quarantine"
End If


End Sub

 

[M4TVD]

The most important thing that I require the code to do is to insert the new row in the same row number in both sheets, the sheets being "ALL PARTS" and "Build Output", which MUST be the row below the active cell in "ALL PARTS" sheet.

 

[M4TVD]

I found a solution, using a number of sub calls into what I have called MasterMacroInsertPart.

Sub InsertCopyOfPart() 'Insert into All Parts ONLY
   With ActiveCell
      .Offset(1).EntireRow.Insert
      Cells(.Row, 1).Resize(2, 13).FillDown
            
   End With
End Sub


Sub ActiveCellSelect()
targetcell = ActiveCell.Address
OriginSheet = ActiveSheet.Name
Dim ws As Worksheet
For Each ws In Sheets
    If ws.Visible = True Then ws.Select (False)
Next ws
Range(targetcell).Select
Sheets(OriginSheet).Select
End Sub

Sub InsertCopyOfPartBuildOutput() 'Insert into Build Output ONLY
   Worksheets("Build Output").Activate
   With ActiveCell
   .Offset(1).EntireRow.Insert
      Cells(.Row, 1).Resize(2, 13).FillDown
            
   End With
End Sub

Sub InsertCopyOfPartBuildOutputSPARE() 'Insert into Build Output ONLY
   Worksheets("Build Output (SPARE)").Activate
   With ActiveCell
   .Offset(1).EntireRow.Insert
      Cells(.Row, 1).Resize(2, 13).FillDown
            
   End With
End Sub

Sub MasterMacroInsertPart() 'Combines all insert macros into one command
    Call ActiveCellSelect
    Call InsertCopyOfPart
    Call InsertCopyOfPartBuildOutput
    Call InsertCopyOfPartBuildOutputSPARE

     
End Sub

Only Problem that I have found with this combination of commands is that after I run it, It leaves me active on the "Build Output" sheet when I want to be on the "All Parts" sheet that the Buttons are on.

 

[My Aswer Is This]

Try this:

Sub InsertCopyOfPart()
'Modified  11/22/2021  8:09:47 AM  EST
Application.ScreenUpdating = True
Dim r As Long
r = ActiveCell.Row
  
  
   With ActiveCell
      .Offset(1).EntireRow.Insert
      Cells(.Row, 1).Resize(2, 13).FillDown
            Sheets("Build Output").Rows(r).Insert
   End With

Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Glad I was able to help you.
Come back here to Mr. Excel next time you need additional assistance.