VBA Code Help Bounty 1/5 Star Difficulty

[yukonhoe]

The FORMAT of cells in Col D to "Accounting" gave me a good run. After editing the format things moved along rather well.

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
    
          '''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 = 200
    Range("H" & lastRow).EntireRow.Offset(1).Resize(var).Insert Shift:=xlDown
    
    
    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
    
    'clear the totals at bottom of ranges
    LR = Range("A3").End(xlDown).Row
    Rows(LR + 1 & ":" & 10000).Delete
    
    Application.ScreenUpdating = True
    
End Sub

All the zero's are getting deleted correctly it looks like, however I am losing the total/sum's rows below the data, I need this to carry over every time to macro is run. Copy values from H ctrl down (this doesnt grab the totals as there is blank row between data and totals/sums) paste values in d, delete zeros from d (using variable range of h + ctrl down) , delete out e:G + variable range of h +ctrl down, add 200 blank rows in between the h + ctrl down and the totals/sums

[Logit]

To retain the totals at the bottom of the range, delete the following lines of code located at the very bottom of the macro :

'clear the totals at bottom of ranges   
LR = Range("A3").End(xlDown).Row
Rows(LR + 1 & ":" & 10000).Delete

[yukonhoe]

To retain the totals at the bottom of the range, delete the following lines of code located at the very bottom of the macro :

'clear the totals at bottom of ranges   
LR = Range("A3").End(xlDown).Row
Rows(LR + 1 & ":" & 10000).Delete

How can I get the "insert 200 blank lines into this, doesnt appear to be adding lines.

[Logit]

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 200 blank rows to make space for new period data'''
                
    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
    
     
    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

[yukonhoe]

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 200 blank rows to make space for new period data'''
                
    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
    
     
    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

This appears to work, will run thru few diff formats and confirm

[Logit]

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

[snb]

Sub M_snb()
   With Sheet2.Columns(8)
      .SpecialCells(-4123, 1).Areas(1).Value = .SpecialCells(-4123, 1).Areas(1).Value
      .SpecialCells(2, 1).Replace 0, "", 1
      .SpecialCells(4).EntireRow.Delete
      With .SpecialCells(2, 1).Areas(1)
        .Offset(, -4) = .Value
        .Offset(, -3).Resize(, 3).ClearContents
        .Formula = "=sum($D2:$G2)"
      End With
    End With
End Sub

[Jan Karel Pieterse]

You mention updating the code in many files. Have a look at:
https://jkp-ads.com/download.asp#CopyVBAProject