![]() |
|
#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
|
|
|
|
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 |
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 |
Count rows and add blank rows accordingly
|
Hoochtheseal | Word VBA | 1 | 01-29-2013 09:23 PM |