Consolidating two Macros into One - vba

Question

I have two similar macros I've written, and for efficiency's sake I'd like to consolidate them into one. The first macro adds 4 blank rows on another tab underneath a specific row, where column C matches certain criteria. The second macro copies 4 rows of data from an existing tab over to the new tab, and pastes that data into the 4 newly created blank rows. Any help would be greatly appreciated! Thank you
Conceptual screenshots attached:
Screenshot 1: Initial State
Screenshot 2: MACRO 1 inserts 4 rows if criteria in column C is met (in this case value = "Part A"
Screenshot 3: MACRO 2 pulls in row data from another sheet and pastes it into the new blank rows on this sheet
FIRST MACRO:
Sub RowAdder_01()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim PN_01 As Range
Set PN_01 = Range("M17")
Col = "C"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With Worksheets("NEW SHEET")
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = PN_01 Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
SECOND MACRO:
Sub PasteRowData_01()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim PN_01 As Range
Set PN_01 = Range("M17")
Col = "C"
Drop = "A"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
Sheets("OLD SHEET").Rows("54:57").SpecialCells(xlCellTypeVisible).Select
Selection.Copy
With Worksheets("NEW SHEET")
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = PN_01 Then
Sheets(NEW SHEET).Select
.Cells(R + 1, Drop).Select
Selection.PasteSpecial
End If
Next R
End With
Application.ScreenUpdating = True
End Sub

Answer 1

Please try this code.
Option Explicit
Sub AddAndPaste()
Dim Ws As Worksheet
Dim Arr As Variant
Dim PN_01 As Variant
Dim Last As Long ' column or row
Dim R As Long
' copy from source
Set Ws = Worksheets("Old Sheet")
With Ws
With .UsedRange
Last = .Columns.Count + .Column - 1
End With
Arr = Range(.Cells(54, 1), .Cells(57, Last)).SpecialCells(xlCellTypeVisible).Value
End With
Application.ScreenUpdating = False
' paste to destination
Set Ws = Worksheets("New Sheet")
With Ws
PN_01 = .Cells(7, "M").Value
Last = .Cells(.Rows.Count, "C").End(xlUp).Row
For R = Last To 1 Step -1
If .Cells(R, "C").Value = PN_01 Then
With .Cells(R, "A")
.Resize(4, 1).EntireRow.Insert Shift:=xlDown
.Offset(-4).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
End With
Exit For ' don't exit if you need to continue looping
End If
Next R
End With
Application.ScreenUpdating = True
End Sub

Answer 2

Your problem is caused by inserting a line. We recommend using an array.
Sub test()
Dim Ws As Worksheet, newWs As Worksheet, Temp As Worksheet
Dim vDB, vSp, vR()
Dim i As Long, r As Long, n As Long, k As Integer, cnt As Integer
Dim PN_01 As Range
Set newWs = Sheets("New Sheet")
Set oldWs = Sheets("OLD SHEET")
Set Temp = Sheets.Add
oldWs.Range("a54:d57").SpecialCells(xlCellTypeVisible).Copy Temp.Range("a1")
vSp = Temp.UsedRange
Application.DisplayAlerts = False
Temp.Delete
Application.DisplayAlerts = True
With newWs
vDB = .Range("a1", "d" & .Range("a" & Rows.Count).End(xlUp).Row)
Set PN_01 = .Range("M17")
End With
cnt = UBound(vSp, 1)
r = UBound(vDB, 1)
For i = 1 To r
n = n + 1
ReDim Preserve vR(1 To 4, 1 To n)
For j = 1 To 4
vR(j, n) = vDB(i, j)
Next j
If vDB(i, 3) = PN_01 Then
For k = 1 To cnt
n = n + 1
ReDim Preserve vR(1 To 4, 1 To n)
For j = 1 To 4
vR(j, n) = vSp(k, j)
Next j
Next k
End If
Next i
newWs.Range("a1").Resize(n, 4) = WorksheetFunction.Transpose(vR)
newWs.Activate
End Sub