End sub/with problem

**dalewms2** · 10-13-2011, 02:09 PM

If I end the code with End Sub I get an error message that the program was expecting End With. When I use End With the program was expecting End Sub.

Also within the following code can someone tell me exactly and only which lines to take out so the macro will stop counting empty cells. I only need to delete duplicate rows.

Sub DeleteDuplicateEntries()
   Dim rClMain As Range
   Dim rClDupe As Range
   Dim rCheck
   Dim N As Long
   Application.ScreenUpdating = False
   N = 0
       'currently starts in A2 down,adjust to your data
   Set rCheck = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
   For Each rClMain In rCheck
        '1st loop - (to speed things up ignore any empty cells)
       If rClMain <> Empty Then
           For Each rClDupe In rCheck
                '2nd loop - compare non-empty rClDupe values
                'and clear contents if it's a duplicated value
               If rClDupe <> Empty And _
               rClDupe.Value = rClMain.Value And _
               rClDupe.Address <> rClMain.Address Then
                   rClDupe.EntireRow.Delete
                   N = N + 1
               End If
           Next rClDupe
       End If
   Next
   Application.ScreenUpdating = True
   MsgBox "There were " & N & " duplicated entries deleted"
End Sub

**tigeravatar** · 10-13-2011, 02:49 PM

dalewms2,

You should be able to use the following to delete duplicates while ignoring blanks:

Sub DeleteDuplicateEntries()
    
    Dim rngDupChk As Range
    
    With Intersect(ActiveSheet.UsedRange, Columns("A"))
        Set rngDupChk = .Offset(, ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count)
        rngDupChk.Formula = "=If(A" & .Row & "="""",0,If(countif(" & .Address & ",A" & .Row & ")>1,1,0))"
    End With
    
    With rngDupChk
        .AutoFilter 1, 1
        .Offset(1).EntireRow.Delete
        .AutoFilter
        .EntireColumn.Delete
    End With
    
End Sub

**6StringJazzer** · 10-13-2011, 02:51 PM

Your code tags are messed up, please correct.

Your attached file does not have any code in it.

I pasted your code above and it compiled and ran fine with no errors. Here is the (correctly formatted) version of what I actually ran:

Sub DeleteDuplicateEntries()

   Dim rClMain As Range
   Dim rClDupe As Range
   Dim rCheck
   Dim N As Long
   
   Application.ScreenUpdating = False
   N = 0
   
   'currently starts in A2 down,adjust to your data
   Set rCheck = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
   
   For Each rClMain In rCheck
      '1st loop - (to speed things up ignore any empty cells)
      If rClMain <> Empty Then
         For Each rClDupe In rCheck
            '2nd loop - compare non-empty rClDupe values
            'and clear contents if it's a duplicated value
            If rClDupe <> Empty And _
               rClDupe.Value = rClMain.Value And _
               rClDupe.Address <> rClMain.Address Then
               rClDupe.EntireRow.Delete
               N = N + 1
            End If
         Next rClDupe
      End If
   Next
   
   Application.ScreenUpdating = True
   MsgBox "There were " & N & " duplicated entries deleted"

End Sub

I don't understand your second question. This code does not count empty cells.

**Whizbang** · 10-13-2011, 02:57 PM

Subs will always end with "End Sub", so that should always be there. What the error is telling you is that there is a With statement that does not have an End With. Since there is no With statement in your code, I can only assume that the problem lies elsewhere. I copied your code into a blank workbook and it compiled just fine. I threw together some dummy data and it ran fine for that as well.

**dalewms2** · 10-13-2011, 03:11 PM

Can someone tell me what's wrong when you open a spreadsheet and the macro is no longer there. I even opened the spreadsheet I attached to this question.

**Whizbang** · 10-13-2011, 03:23 PM

My guess is that you saved it as an .xlsx and then saved it as a .xlsm.

**dalewms2** · 10-13-2011, 03:59 PM

Same macro. Different workbook. I am now getting a run time error 438 Object doesn't support this property at the point I highlighted below.

Sub LTWO()
'
' LTWO Macro
'
' Keyboard Shortcut: Ctrl+m
'
    Range("A2").Select
    
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "SHIP_DATE"
     Range("B1").Select
    ActiveCell.FormulaR1C1 = "WB NBR"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "CAR_INIT"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "CAR_NBR"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "CAR MARK & DATE"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "ORIGIN"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "DESTINATION"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "L/E CODE"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "STCC"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = " TOTAL"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = " SUPPLEMENT"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = " AMT_CLAIM"





    
    With ActiveSheet
        BottomRow = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
        
        .Columns("E:E").Insert Shift:=xlToRight
        .Range("E1").FormulaR1C1 = "CAR MARK"
        .Range("E2:E" & BottomRow).FormulaR1C1 = "=CONCATENATE(RC[-2],"" "",RC[-1])"
        .Columns("E:E").AutoFit
    
        .Columns("A:A").Insert Shift:=xlToRight
        .Range("A2:A" & BottomRow).FormulaR1C1 = "=CONCATENATE(RC[2],RC[3],RC[4])"
        .Columns("A:A").AutoFit
        
        .Range("L2:L" & BottomRow).FormulaR1C1 = _
            "=SUMIF(R[1]C[-11]:R" & BottomRow + 1 & "C1,RC[-11],R[1]C[-1]:R" & BottomRow + 1 & "C[-1])"
    
        .UsedRange.Value = .UsedRange.Value
    
        .Range("M2:M" & BottomRow).FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"
    
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("M2:M" & BottomRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=Range( _
            "D2:D" & BottomRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=Range( _
            "B2:B" & BottomRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A1").CurrentRegion
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        
      
    
    Dim rngDupChk As Range
    
    With Intersect(ActiveSheet.UsedRange, Columns("A"))
        Set rngDupChk = .Offset(, ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count)
        rngDupChk.Formula = "=If(A" & .Row & "="""",0,If(countif(" & .Address & ",A" & .Row & ")>1,1,0))"
    End With
    
    With rngDupChk
        .AutoFilter 1, 1
        .Offset(1).EntireRow.Delete
        .AutoFilter
        .EntireColumn.Delete
    End With
    

        
        BottomRow = .UsedRange.SpecialCells(xlCellTypeLastCell).Row    
        With .Range("K" & BottomRow & ":M" & BottomRow)
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            .Borders(xlEdgeLeft).LineStyle = xlNone
            .Borders(xlEdgeTop).LineStyle = xlNone
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            .Borders(xlEdgeRight).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
        
        .Range("K" & BottomRow + 1).FormulaR1C1 = "=SUM(R[-" & BottomRow - 1 & "]C:R[-1]C)"
        .Range("L" & BottomRow + 1).FormulaR1C1 = "=SUM(R[-" & BottomRow - 1 & "]C:R[-1]C)"
        .Range("M" & BottomRow + 1).FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"
  End With
    Range("A2").Select
End With
End Sub

**Whizbang** · 10-13-2011, 04:50 PM

And this is why you should provide all your code.

Here is your missing End With:

        With .Sort
            .SetRange Range("A1").CurrentRegion
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply

As for your error, your highlight does not show in a Code box. Please call the specific line out in its own code box.

**dalewms2** · 10-13-2011, 04:53 PM

This is the code that gives the error

 BottomRow = .UsedRange.SpecialCells(xlCellTypeLastCell).Row

**Whizbang** · 10-13-2011, 05:02 PM

This error is due to your missing End With I pointed out in my previous post.

The sub is still in "With .Sort" mode, so

BottomRow = .UsedRange.SpecialCells(xlCellTypeLastCell).Row

is really

BottomRow = ActiveSheet.Sort.UsedRange.SpecialCells(xlCellTypeLastCell).Row

Which is wrong.

End sub/with problem

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

End sub/with problem

Re: End sub/with problem

Re: End sub/with problem

Re: End sub/with problem

Re: End sub/with problem

Re: End sub/with problem

Re: End sub/with problem

Re: End sub/with problem

Re: End sub/with problem

Re: End sub/with problem

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions