PDA

View Full Version : Removing blank lines from report calculated by macro



rey06
02-18-2016, 07:49 AM
Hi - I'm sure my subject line is super confusing, but I can explain.
I have the below code (thanks to help I got here!) that makes wonderful reports and exports them to a new location.
However, they are being exported with several blank lines where there was once a formula. I don't think Excel is seeing them as blank lines though, which might be a problem. Is there a way to alter the below code to remove those blank lines?

Previous forum - http://www.vbaexpress.com/forum/showthread.php?55166-Move-data-from-one-sheet-to-another-and-export&p=338412#post338412

Code


Option Explicit

Sub DiscrepancyReport()
Dim Wb As Workbook
Dim xWs As Worksheet
Dim DateBox As String
Dim xPath As String
xPath = ThisWorkbook.Path

DateBox = InputBox("DISCREPANCY REPORTS: Please enter the date YYYYMM")

'Application.ScreenUpdating = False
'Application.DisplayAlerts = False

For Each xWs In ThisWorkbook.Sheets
If xWs.Name <> "MACROS" And xWs.Name <> "Flat File" And xWs.Name <> "DisInput" And xWs.Name <> "DisReport" Then
xWs.Cells.Copy Sheets("DisInput").Range("A1")
Application.Calculate
Sheets("DisReport").Copy
With ActiveSheet.Cells
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" _
& DateBox & "_" _
& Sheets("DisReport").Range("AK2") _
& "_Discrepancy Report" & ".xlsx"
Application.ActiveWorkbook.Close False
End If
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True
ThisWorkbook.Activate
End Sub

SamT
02-18-2016, 05:08 PM
I don't think Excel is seeing them as blank lines though, which might be a problem.
Why do you think that?

rey06
02-18-2016, 07:31 PM
Why do you think that?

Don't laugh at my terminology here, but when I do a ctrl-shift-down, it goes down to where my formula ended whether there is data populated in the cells or not.

SamT
02-18-2016, 09:26 PM
What is in the Formula Bar when you stop there?

shailendranr
02-18-2016, 09:37 PM
do you want to remove the entire row of blanks then use this code

select a column i assume here column as a:a

Range("a:a").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

thats it

rey06
02-19-2016, 07:15 AM
What is in the Formula Bar when you stop there?

Nothin'. That's why I don't think Excel is seeing these lines as "blank." I could be wrong.
VBA is completely new to me, but it's cut a 2 hour project each month down to about 30 seconds, so I'm pleased so far.

rey06
02-19-2016, 07:16 AM
do you want to remove the entire row of blanks then use this code

select a column i assume here column as a:a

Range("a:a").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

thats it

How does this fit into the code I posted?

SamT
02-19-2016, 09:57 AM
I would live with it, unless it becomes an issue.

rey06
02-19-2016, 11:58 AM
I would live with it, unless it becomes an issue.

The only issue I have is that it makes the file size so large.

SamT
02-19-2016, 01:22 PM
Sub ExcelDiet()
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=83
'By Jacob Hilderbrand
Dim j As Long
Dim k As Long
Dim LastRow As Long
Dim LastCol As Long
Dim ColFormula As Range
Dim RowFormula As Range
Dim ColValue As Range
Dim RowValue As Range
Dim Shp As Shape
Dim ws As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False

On Error Resume Next

For Each ws In Worksheets
With ws
'Find the last used cell with a formula and value
'Search by Columns and Rows
On Error Resume Next
Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
On Error GoTo 0

'Determine the last column
If ColFormula Is Nothing Then
LastCol = 0
Else
LastCol = ColFormula.Column
End If
If Not ColValue Is Nothing Then
LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
End If

'Determine the last row
If RowFormula Is Nothing Then
LastRow = 0
Else
LastRow = RowFormula.Row
End If
If Not RowValue Is Nothing Then
LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
End If

'Determine if any shapes are beyond the last row and last column
For Each Shp In .Shapes
j = 0
k = 0
On Error Resume Next
j = Shp.TopLeftCell.Row
k = Shp.TopLeftCell.Column
On Error GoTo 0
If j > 0 And k > 0 Then
Do Until .Cells(j, k).Top > Shp.Top + Shp.Height
j = j + 1
Loop
If j > LastRow Then
LastRow = j
End If
Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
k = k + 1
Loop
If k > LastCol Then
LastCol = k
End If
End If
Next

.Range(Cells(1, LastCol + 1).Address & ":IV65536").Delete
.Range(Cells(LastRow + 1, 1).Address & ":IV65536").Delete
End With
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub