Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 09-19-2018, 10:46 AM
kevinbradley57 kevinbradley57 is offline Somehow getting extra blank rows with borders Windows 7 64bit Somehow getting extra blank rows with borders Office 2010 64bit
Advanced Beginner
Somehow getting extra blank rows with borders
 
Join Date: Jul 2017
Posts: 84
kevinbradley57 is on a distinguished road
Default Somehow getting extra blank rows with borders

I have a macro that retrieves data from an external spreadsheet, runs various edits on the data, removes duplicates, and then adds borders around the used range. Unfortunately, it also adds blank rows at the bottom of the spreadsheet and I can't figure out why it's doing that or how to get rid of them. Any help would be greatly appreciated. Yes, I know the code is a mess. It was cobbled together by a rookie (me) and evolved as columns were added. I would welcome any suggestions for making it cleaner.



Code:
Sub GetDaily()
   Dim wb As Workbook, src As Workbook
   Dim sht As Worksheet, cel As Range
   Dim lr As Long
 
Set sht = ThisWorkbook.ActiveSheet
'remove existing data
    Columns("A:A").Select
    Selection.ColumnWidth = 5
    Columns("B:B").Select
    Selection.ColumnWidth = 30
    Columns("C:C").Select
    Selection.ColumnWidth = 20
    Columns("D:D").Select
    Selection.ColumnWidth = 20
    Columns("E:E").Select
    Selection.ColumnWidth = 8
    Columns("F:F").Select
    Selection.ColumnWidth = 8
    Columns("G:G").Select
    Selection.ColumnWidth = 8
    Columns("H:H").Select
    Selection.ColumnWidth = 9
    Columns("J:J").Select
    Selection.ColumnWidth = 60
    Columns("K:K").Select
    Selection.ColumnWidth = 10.5
    Columns("L:L").Select
    Selection.ColumnWidth = 11
With sht.UsedRange.Offset(1)
   .Borders.LineStyle = xlNone
   .ClearContents
End With
'see if source is open
For Each wb In Application.Workbooks
   If wb.Name = "SearchResultsDaily " & Format(Date, "m.d.yy") & ".xls" Then
       Set src = wb
       Exit For
   End If
Next wb
'if yes copy data
If Not src Is Nothing Then
   src.Sheets(1).UsedRange.Offset(1).Copy
'if no display message and quit
Else
   MsgBox "Workbook   " & Chr(34) & "SearchResultsDaily " & _
           Format(Date, "m.d.yy") & ".xls" & Chr(34) & "   is not open."
   Exit Sub
End If
'paste the copied data
With sht
   .Cells(2, 1).PasteSpecial (xlPasteValues)
   'name sheet
'   .Name = Left(src.Name, Len(src.Name) - 4)
   ' E from F if blank
   For Each cel In Intersect(.Columns("E"), .UsedRange)
       If cel.Value = "" Then cel.Value = cel.Offset(, 1).Value
   Next cel
   'position the cursor for sorting
      .Cells(2, 5).Select
   'determine last row
   lr = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
With ActiveSheet
    .Range("A1:L" & .Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes
End With
   With .Sort
       .SortFields.Clear
       .SortFields.Add Key:=Range("F2"), SortOn:=xlSortOnValues, Order:=xlAscending, _
                            DataOption:=xlSortTextAsNumbers
       .SetRange Range("A2:J" & lr)
       .Header = xlNo
       .MatchCase = False
       .Orientation = xlTopToBottom
       .SortMethod = xlPinYin
       .Apply
   End With
End With
  Columns("A:L").Select
    With Selection
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
'   .Cells(1).Select
'End With
'stop the marching ants
Application.CutCopyMode = False
 
'Remove username from audit director names.
    Dim rng As Range
lr = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Set rng = Union(Range("C1:C" & lr), Range("D1:D" & lr))
rng.Replace What:=" (*)", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _
                        MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'Remove AUDIT- from AUDIT-XXXX in column A
    Columns("A:A").Select
    Selection.Replace What:="AUDIT-", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 
    With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
'Change Needs Improvement to IN and Satisfactory to Sat in column G.
    Columns("G:G").Select
    Selection.Replace What:="Needs Improvement", Replacement:="IN", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Satisfactory", Replacement:="Sat", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Put borders around new rows.
With ActiveSheet.UsedRange.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
With ActiveSheet.UsedRange.Font
        .Name = "Arial"
        .Size = 8
    End With
 
Range("A1").Select
ActiveWorkbook.SaveAs "Daily Plan Status " & Format(Date, "m.d.yy") & ".xlsm"
End Sub
Reply With Quote
  #2  
Old 09-19-2018, 12:35 PM
NoSparks NoSparks is offline Somehow getting extra blank rows with borders Windows 7 64bit Somehow getting extra blank rows with borders Office 2010 64bit
Excel Hobbyist
 
Join Date: Nov 2013
Location: British Columbia, Canada
Posts: 831
NoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really nice
Default

Excel doesn't automatically reset the used range until the workbook is saved.

This is untested but you might get a reset on the fly with one of these two instructions right ahead of putting in the boarders and fonts.
Code:
    ActiveSheet.UsedRange
    X = ActiveSheet.UsedRange.Rows.Count
'Put borders around new rows.
Reply With Quote
  #3  
Old 09-19-2018, 12:45 PM
kevinbradley57 kevinbradley57 is offline Somehow getting extra blank rows with borders Windows 7 64bit Somehow getting extra blank rows with borders Office 2010 64bit
Advanced Beginner
Somehow getting extra blank rows with borders
 
Join Date: Jul 2017
Posts: 84
kevinbradley57 is on a distinguished road
Default

NoSparks - Thanks for the quick response, but neither of those instructions worked for me.
Reply With Quote
  #4  
Old 09-19-2018, 01:01 PM
kevinbradley57 kevinbradley57 is offline Somehow getting extra blank rows with borders Windows 7 64bit Somehow getting extra blank rows with borders Office 2010 64bit
Advanced Beginner
Somehow getting extra blank rows with borders
 
Join Date: Jul 2017
Posts: 84
kevinbradley57 is on a distinguished road
Default

NoSparks -- Your comment inspired me to look for (and find) code that resets the used range when data is copied from another source (that last bit is important). This works:
Code:
Sub Delete_Empty_Row()
    Application.ScreenUpdating = False
    For Each usedrng In ActiveSheet.UsedRange
        If usedrng.MergeCells = True Then
            If usedrng.Value = "" Then
                usedrng.Value = ""
            End If
        Else
            If usedrng.Value = "" Then
                usedrng.ClearContents
            End If
        End If
    Next
    
    ActiveSheet.UsedRange
    usedRangeLastColNum = ActiveSheet.UsedRange.Columns.Count
    usedrangelastrow = ActiveSheet.UsedRange.Rows.Count
    
    For r = usedrangelastrow To 1 Step -1
        If Application.WorksheetFunction.CountA(Cells(r, usedRangeLastColNum).EntireRow) <> 0 Then
            Exit For
        Else
            Cells(r, usedRangeLastColNum).EntireRow.Delete
        End If
    Next r
    
    For c = usedRangeLastColNum To 1 Step -1
        If Application.WorksheetFunction.CountA(Cells(1, c).EntireColumn) <> 0 Then
            Exit For
        Else
            Cells(1, c).EntireColumn.Delete
        End If
    Next c
    
    ActiveSheet.UsedRange
    Application.ScreenUpdating = True
End Sub
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Template with background colors has extra blank page that will not delete. jspinelli27 Word 1 03-11-2018 02:27 PM
Section Break Inserts an Extra Blank Page Nathan8752 Word 3 12-09-2015 07:03 AM
Somehow getting extra blank rows with borders Delete blank rows between the two rows that contain data beginner Excel Programming 5 12-26-2014 12:29 AM
Extra lines in directroy when field is blank redzan Mail Merge 5 05-23-2014 06:40 PM
Somehow getting extra blank rows with borders Count rows and add blank rows accordingly Hoochtheseal Word VBA 1 01-29-2013 09:23 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 02:33 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft