See if this works :
Public Sub PD()
'''rename sheet'''
Dim newName As String
On Error Resume Next
newName = InputBox("Enter the name for the copied worksheet")
'''duplicate current tab'''
If newName <> "" Then
ActiveSheet.Copy Before:=Sheets(1)
On Error Resume Next
ActiveSheet.Name = newName
End If
Application.ScreenUpdating = False
'''copy end of period balances from I9 to last cell with data in row H5'''
Dim lastRow As Long
lastRow = Range("H3").End(xlDown).Row
Set Rng = Range("H3:H" & lastRow)
Range("H3:H" & lastRow).Copy
'''paste copied end balances and paste values to cell D5'''
ActiveSheet.Range("D3").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Applcation.CutCopyMode = False
Range("D1:D200").NumberFormat = "Number"
'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long
Set Sht = ActiveSheet
last = Sht.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row
For i = last To 30 Step -1
If Cells(i, "D").Value = "0" Then
Cells(i, "D").EntireRow.Delete
End If
Next i
Dim LR As Long
Application.ScreenUpdating = False '\/Change number 1 below to correspond to affected column.
LR = Sheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row '<----- Change to actual sheet name
With Range("D2:D200" & LR) '<-- Change to corresponding row
.Replace 0, "", xlWhole '<-- Currently checking for number 0. Edit as required
.SpecialCells(4).EntireRow.Delete
End With
Range("E3:E200" & LR).ClearContents '<-- Change to corresponding row
Dim wbMe As Excel.Workbook
Dim cl As Excel.Range
Set wbMe = ThisWorkbook
'if number is negative, change to positive
Set cl = activeworksheet.Range("D3:D200").Select
If cl.Value < 0 Then
cl.Value = -cl.Value
End If
'''insert 50 blank rows to make space for new period data'''
'''grabs count of new accruals for period from cell N1'''
'Dim var As Integer
'var = 50
'Range("A" & lastrow).EntireRow.Offset(1).Resize(var).Insert Shift:=xlDown
Dim numRowsToAdd As Integer
' Find the last used cell in column A
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
' Get the number of blank rows to add
numRowsToAdd = 200
' Add blank rows below the last used cell
For i = 1 To numRowsToAdd
Rows(lastRow + i).Insert Shift:=xlDown
Next i
Dim newrow As Long
' Find the last used cell in column D
lastRow = Cells(Rows.Count, 4).End(xlUp).Row
newrow = lastRow - 1
Rows(newrow).Insert Shift:=xlDown
Range("A1").Select
Application.ScreenUpdating = False
''clear the totals at bottom of ranges
'LR = Range("A3").End(xlDown).Row
'Rows(LR + 1 & ":" & 10000).Delete
Application.ScreenUpdating = True
End Sub