VBA Code Help Bounty 1/5 Star Difficulty

[yukonhoe]

Haven't bothered to read rules, apologies in advance. Wrote this awhile ago, forgot VBA since and don't have time atm to reteach myself. This might be against TOS but first to fix this, I might (I do) have for you, = 1 united state dollar... if this is against TOS can you please remove these lines from this post instead of deleting it and making me repost? Forums are aids.


Should be easy fix, prob need to move order in some form.

'''deletes rows with zero values in column D''' this part of code below, last piece, this isnt working correctly. It is only deleting some of the zeros but not all. Maybe bc insert 200 line is before this? This step could be done before the line add code in an order of operations, but not before column H is pasted hard values into column D.


Let me know, thx in advance; will pm solver. Might need to develop relationship with someone , monetarily that is, we back baby.

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
    
     '''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
    
    
     '''clear middle aread from columns E to H'''
    Range("E3:G" & lastRow).ClearContents
    
        '''deletes rows with zero values in column D'''
    Dim Sht As Worksheet
    Dim last As Long
    Dim i As Long
    Set Sht = ActiveSheet
    last = Cells(Rows.Count, "D3").End(xlDown).Row
    For i = last To 30 Step 1
        If Cells(i, "D").Value = "0" Then
                Cells(i, "D").EntireRow.Delete
        End If
    Next i
    
   
    
    
End Sub

[yukonhoe]

Duplicate the bounty if someone can tell me if there is method to updating 100+ excel sheets that currently have this glitched code in it into a different one. I understand you could just save in one file and keep open, would prefer the former.

edit - I also understand that this ^ has likely been discussed before either here or the www, cant bother to search for it

[arnelgp]

maybe delete the last portion of your code to:

       '''deletes rows with zero values in column D'''
  Dim Sht As Worksheet
    Dim last As Long
    Dim i As Long
    Set Sht = ActiveSheet
    last = Cells(Rows.Count, "D").End(xlUp).Row
    
    Do While last > 29
        If Cells(last, "D").Value & "" = "0" Then
                Rows(last).Delete
        End If
        last = last - 1
    Loop

[jdelano]

If the value in D isn't a string it might cause the if fail.

I would try to surround the cell value with a CStr() function so that it converts any number to a string during the comparison.

        '''deletes rows with zero values in column D'''
    Dim Sht As Worksheet
    Dim last As Long
    Dim i As Long
    Set Sht = ActiveSheet
    last = Cells(Rows.Count, "D3").End(xlDown).Row
    For i = last To 30 Step 1
        If CStr(Cells(i, "D").Value) = "0" Then
                Cells(i, "D").EntireRow.Delete
        End If
    Next i

[Logit]

Here is the reworked macro :

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
    
     '''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
    
    
      '''deletes rows with zero values in column D'''
    'Dim Sht As Worksheet
    'Dim last As Long
    'Dim i As Long
    'Set Sht = ActiveSheet
    'last = Cells(Rows.Count, "D3").End(xlDown).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:D" & lr)                                   '<-- Change to corresponding row
        .Replace " ", "", xlWhole                               '<-- Currently checking for number 0. Edit as required
        .SpecialCells(4).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
    
    
   
    
    
End Sub

[yukonhoe]

Still running into same issue, doesnt delete every row with a zero from column D, only some of them.

[yukonhoe]

maybe delete the last portion of your code to:

       '''deletes rows with zero values in column D'''
  Dim Sht As Worksheet
    Dim last As Long
    Dim i As Long
    Set Sht = ActiveSheet
    last = Cells(Rows.Count, "D").End(xlUp).Row
    
    Do While last > 29
        If Cells(last, "D").Value & "" = "0" Then
                Rows(last).Delete
        End If
        last = last - 1
    Loop

This is close, all the zero value cells in column D are now grouped together, but still manually need to delete.

[yukonhoe]

If the value in D isn't a string it might cause the if fail.

I would try to surround the cell value with a CStr() function so that it converts any number to a string during the comparison.

        '''deletes rows with zero values in column D'''
    Dim Sht As Worksheet
    Dim last As Long
    Dim i As Long
    Set Sht = ActiveSheet
    last = Cells(Rows.Count, "D3").End(xlDown).Row
    For i = last To 30 Step 1
        If CStr(Cells(i, "D").Value) = "0" Then
                Cells(i, "D").EntireRow.Delete
        End If
    Next i

No dice, zero's in column D are still being skipped

[yukonhoe]

For those I have replied to, please see the excel file that user logit has linked, that is an example of my file if you want to play with it.

[jdelano]

The calc for the last row was always returning 0 and the step was 1 and not -1 ... it looks to me like it is doing what you need now.

[yukonhoe]

The calc for the last row was always returning 0 and the step was 1 and not -1 ... it looks to me like it is doing what you need now.

Can you paste the macro, something is up with excel files getting posted here, pc thinks they are dangerous since coming from web

[jdelano]

Can you paste the macro, something is up with excel files getting posted here, pc thinks they are dangerous since coming from web

     '''deletes rows with zero values in column D'''
    Dim Sht As Worksheet
    Dim last As Long
    Dim i As Long
    Set Sht = ActiveSheet
    'last = Cells(Rows.Count, "D3").End(xlDown).Row
    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
                'Cells(1, "J").Value = Cells(1, "J").Value & " " & CStr(i)
        End If
    Next i

[yukonhoe]

     '''deletes rows with zero values in column D'''
    Dim Sht As Worksheet
    Dim last As Long
    Dim i As Long
    Set Sht = ActiveSheet
    'last = Cells(Rows.Count, "D3").End(xlDown).Row
    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
                'Cells(1, "J").Value = Cells(1, "J").Value & " " & CStr(i)
        End If
    Next i

Close, all the values with zero in column d post macro are now lumped together, need it to delete these sheet row's after identifying that they are zero's. Everything else looks good.

[jdelano]

even before row 30? The loop has a hard stop there.

[yukonhoe]

Close, all the values with zero in column d post macro are now lumped together, need it to delete these sheet row's after identifying that they are zero's. Everything else looks good.

So the data within the sheet will always be changing, but it will always be setup the same . I ran on a diff data sheet and cells with positive integer in column d post macro column h pre macro were stand alone within the group of zero value rows. wish I could paste screenshots in this forum... lmk if this made any sense, either way zero's arent getting delete and if zero's get deleted this should work perfectly.

[yukonhoe]

even before row 30? The loop has a hard stop there.

Rows 1 and 2 need to stay put and not be altered, if you can see in original code I use ctrl down to set variable length of rows that need to be pasted over. it is variable number of rows, always different, but there is gap in data and totals at bottom so that totals are never grabbed. Ctrl down in column H should always be the number of rows , delete zero's in column d from these rows after paste values, but before adding 200 blank lines above totals/sum line

[yukonhoe]

even before row 30? The loop has a hard stop there.

I see what you mean with hard stop at 30, can we remove this piece? it is deleting all the zero's but leaving them from row 3-29.

[jdelano]

Okay, I'll take a look in the morning with all that in mind.

[arnelgp]

i thought you would stop deleting when it reach row 29?
so you want to process it until it reaches the Header of column D.

see ArnelGP_Test worksheet and press the button.

[Logit]

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