![]() |
#1
|
|||
|
|||
![]() 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 |
#2
|
|||
|
|||
![]()
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. |
#3
|
|||
|
|||
![]()
NoSparks - Thanks for the quick response, but neither of those instructions worked for me.
|
#4
|
|||
|
|||
![]()
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 |
![]() |
|
![]() |
||||
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 |
![]() |
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 |
![]() |
Hoochtheseal | Word VBA | 1 | 01-29-2013 09:23 PM |