Avoiding The Creation of A Bloated Excel File

[Ark68]

I have this code that will:

a) create a new workbook
b) filter the source data in a second open workbook
c) copy the filtered results to the empty worksheet (ws_data) in the new workbook

The code runs well, however, the resulting new file is heavily bloated! With a (visible) range of data occupying A1:W71, the file is 20059kb in size. CTRL-END shows the last cell of the range to be W1048208.

Is anyone able to comment on what may be causing this bloat. It must be the way data is being copied and pasted between workbooks. The source file is only 149kb. Is there a better way to to this avoiding whatever is causing the bloat? If not, a means to reduce the size of the file to a more manageable one. Deleting the rows each time a new workbook is created may be an awkward and time consuming task, so I'd prefer to take a preventative approach rather than reactive if I could.

        For x = 1 To intCount '{2}
            .Range("AH" & x) = DateValue(Right(.Range("AG" & x), 6))
            'trgt_date = .Range("AH" & x)
            trgt_date = "8/11/2016"
            str_nwb = Format(trgt_date, "MMM-DD (DDD)") & " schedule_1.xlsx"
            Workbooks.Add
            With ActiveWorkbook
                Sheets("Sheet1").Name = "DATA"
                Sheets("Sheet2").Name = "STAFF"
                Sheets("Sheet3").Name = "DEV"
                .SaveAs "H:\PWS\Parks\Parks Operations\Sports\Sports17\DATA\" & str_nwb
                Set wb_nwb = Workbooks(str_nwb)
                Set ws_data = wb_nwb.Worksheets("DATA")
                Set ws_staff = wb_nwb.Worksheets("STAFF")
                Set ws_dev = wb_nwb.Worksheets("DEV")
            End With
            Windows(str_nwb).Visible = False
            'filter database
            With ws_sched
                .Range("A1").AutoFilter _
                    Field:=2, _
                    Criteria1:=trgt_date, _
                    VisibleDropDown:=False
                Set srng = .Cells.SpecialCells(xlCellTypeVisible)
                srng.Copy ws_data.Range("A1")
                If ws_sched.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
            End With

 

[Ark68]

Thank you Michael ...
It could be I am unable to understand your suggestion so perhaps I adapated my code incorrectly but the file being created is still over 20k KB in size.

For x = 1 To intCount '{2}
            .Range("AH" & x) = DateValue(Right(.Range("AG" & x), 6))
            'trgt_date = .Range("AH" & x)
            trgt_date = "8/11/2016"
            str_nwb = Format(trgt_date, "MMM-DD (DDD)") & " schedule_1.xlsx"
            Workbooks.Add
            With ActiveWorkbook
                Sheets("Sheet1").Name = "DATA"
                Sheets("Sheet2").Name = "STAFF"
                Sheets("Sheet3").Name = "DEV"
                .SaveAs "H:\PWS\Parks\Parks Operations\Sports\Sports17\DATA\" & str_nwb
                Set wb_nwb = Workbooks(str_nwb)
                Set ws_data = wb_nwb.Worksheets("DATA")
                Set ws_staff = wb_nwb.Worksheets("STAFF")
                Set ws_dev = wb_nwb.Worksheets("DEV")
            End With
            Windows(str_nwb).Visible = False
            'filter database
            With ws_sched
                .Activate
                
                .Range("A1").AutoFilter _
                    Field:=2, _
                    Criteria1:=trgt_date, _
                    VisibleDropDown:=False
                'Set srng = .Range(.Cells(1, 1), .Cells(.Range("A" & Rows.count).End(xlUp).Row, .Cells(1, Columns.count).End(xlToLeft).Column))
                'Set srng = .Cells.SpecialCells(xlCellTypeVisible)
                ActiveSheet.UsedRange
                .UsedRange.Copy ws_data.Range("A1")
                'srng.Copy ws_data.Range("A1")
                If ws_sched.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
            End With

 

[MARK858]

@Ark68, what results do you get if you run the macro below?

Sub Rme()
    Dim x As Long, y As Long

    For x = 1 To Sheets.Count
        With Sheets(x)
            y = Application.Sheets(x).UsedRange.Rows.Count
        End With
        MsgBox y
    Next x

End Sub

 

[Michael M]

Ark...did you run the macro on ALL sheets ??
It may not necessarily be the sheet you think is causing the bloat !!

 

[Ark68]

Hey Mark and Michael ...

Workbook has 3 worksheets. I ran Mark's macro and these were the results:

'Data' = 1048200 rows
'Staff' = 18 rows
'Dev' = 5 rows

I ran the same macro on the source worksheet (where the filtered data is copied from).
Before the filter,

The raw worksheet = 718
After data manipulation = 1048576 rows
After filter application = 1048576 rows

So, it's evident that during data manipulation, extra rows are being processed, and although appearing empty, they are still being added to the range of filtered data. However, these "blank" rows don't show as the typical filtered rows with the blue rows numbers.

if my filter is ...

Range("A1").AutoFilter _
                    Field:=2, _
                    Criteria1:=trgt_date, _
                    VisibleDropDown:=False

I assume that column 2 somehow has values that match the filter criteria of equalling trgt_date? But they the excess rows aren't filtered?
I've very confused or very ... ??

 

[MARK858]

First of all applying a filter doesn't in itself change the used range. If your used range row number was 200 and you apply a filter so that only 20 rows are showing the used range is still 200.

What results do you get if you change...

    ActiveSheet.UsedRange
                .UsedRange.Copy ws_data.Range("A1")

to

Dim y As Long
 y = Application.ActiveSheet.UsedRange.Rows.Count
                .UsedRange.Copy ws_data.Range("A1")

Btw, I am not getting the same results running your code.

 

[Ark68]

Hi Mark, I had to take a break from my project, my apologies for not acknowledging your help sooner.

With you last recommendation, y=1, but the target worksheet still reflected 1048208 rows (20059KB) of which only 49 had any "visible" data in them.
My uneducated assumption is that something unwanted is happening during the raw data manipulation. It seems after that process is where all the extra "empty" rows are being added. But those empty rows are being copied over after the filter is applied which seems unusual considering the different approaches to copying.

If anyone wishes to continue to help me iron this out .... here is the code used to manipulate the source data prior to filtering, and copying and pasting. All data is manipulated in the source workbook "schedule.csv" (718 rows) to build the dataset to be filtered and copied. Perhaps there is something happening here in which cells are being inadvertently being populated.

Barring any preventative solution, perhaps someone has a thought on how I can eliminate all the empty rows from my destination workbook that is bloating it. Something to leave me only with the intended rows of visible data.

From a button push ...

Private Sub F6B_Accept_Click()
    prepare_1
End Sub

 DoEvents
  'Contents
    GetUniques temp_ws
      
    With Workbooks("schedule.csv").Worksheets("temp_ws")
        .Range("C:C").Copy .Range("F:F")
    End With
      
  'Refining
    qfile = "schedule.csv"
    Set ws_core = ws_sched
    Debug.Print ws_core.Name
    
    Refine_Schedule temp_ws
    
    l_trr = ws_sched.Range("A2:A" & llastrow + 1).Cells.SpecialCells(xlCellTypeConstants).count
    l_rrd = llastrow + 1 - l_trr - 1
    
    Missing_rental ar, pr, mr '[rental data missing]
    
    Application.DisplayAlerts = False

    Workbooks("Sports17.xlsm").Activate
    Application.DisplayAlerts = True

    uf2_assess_sched.Show

    Application.ScreenUpdating = True
    
End Sub

[/code]
Sub Refine_Schedule(ByVal temp_ws As Object)

Dim c1 As Long, norec As Long
Dim t_fac As String, myVal As Variant, bv1 As String, bv2 As String
Dim red_ref As Long, red_fcn As Long, red_fac As Long, red_class As Long, red_classc As Long
Dim pctCompl As Single, cntr As Integer
Dim msg1 As String, msga As String, msgb As String, msgc As String

Set temp_ws = Workbooks("schedule.csv").Worksheets("temp_ws")

Application.ScreenUpdating = False

With ws_sched
norec = WorksheetFunction.count(.Range("M:M")) 'count number of records
llastrow = .Cells(Rows.count, 2).End(xlUp).Row 'last row of data

msga = "Refining raw dataset. " & norec & " records."
msgb = "Adding data columns"
msg1 = vbLf & msga & vbLf & msgb
uf1_create_wo1.F6E_msg13.Caption = msg1

If .Range("A2") <> "" Then 'blank line already exists?
.Rows(1).Insert Shift:=xlShiftDown 'insert blank row into schedule.csv (header row)
End If
.Range("M1:X1").Value = .Range("A2:L2").Value 'create headers (M1:X1) from redundant data (A2:L2)
.Columns("A:L").EntireColumn.Delete 'delete redundant columns of data
.Columns.AutoFit

.Columns(1).EntireColumn.Insert 'insert a column at A
.Range("A1").Value = "REC_ID" 'header label
.Columns(1).NumberFormat = "0000000" 'define format for column A (RID = 000000)

.Columns(3).EntireColumn.Insert 'insert a column at C
.Range("C:C").Value = .Range("F:F").Value 'copy column F to newly created C
.Columns(3).NumberFormat = "######" 'define contract# format (######)
.Columns(3).EntireColumn.AutoFit 'autofit
.Columns(6).EntireColumn.Delete 'delete column F (former contract holder)

.Columns(4).EntireColumn.Insert 'insert a column at D
.Range("d1").Value = "AMMNT" 'header label
.Columns(4).EntireColumn.AutoFit 'autofit

.Columns(5).EntireColumn.Insert 'insert a column at e
.Range("e1").Value = "TYPE" 'header label
.Columns(5).EntireColumn.AutoFit 'autofit

.Columns("F:G").EntireColumn.Insert 'insert a column at F & G
.Range("F1").Value = "EVENT" 'header label
.Range("G1").Value = "CUSTOMER" 'header label
.Columns("F:G").EntireColumn.AutoFit

.Columns("J:M").EntireColumn.Insert 'insert a column at J, K, L, M
.Range("J1").Value = "FAC_CONCATENATE" 'header label
.Range("K1").Value = "TYPE1" 'header label
.Range("L1").Value = "UNIT" 'header label
.Range("M1").Value = "CLASS" 'header label
.Range("V1").Value = "DUP_FLAG" 'header label
.Range("W1").Value = "CUST_NUM" 'header label

msgb = "Additional data columns added."
msgc = "Populating new columns."
msg1 = vbLf & msga & vbLf & msgb & vbLf & msgc
uf1_create_wo1.F6E_msg13.Caption = msg1

'For cntr = 1 To 100
For c1 = 2 To llastrow + 1 'populate column J with concat contract+facility+unit
.Range("J" & c1).Value = .Range("C" & c1) & .Range("H" & c1) & .Range("I" & c1)
Next c1

.Columns("J:M").EntireColumn.AutoFit

msgb = "New columns populated."
msgc = "Assessing for redundancy."
msg1 = vbLf & msga & vbLf & msgb & vbLf & msgc
uf1_create_wo1.F6E_msg13.Caption = msg1

For c1 = 2 To llastrow + 1
'redundancy exclusion (records of a non rental nature)
reference_redundancy c1 'reference(P) : "maintenance" (key: "ref")
If .Cells(c1, "A").Value = "" Then fnct_admin_redundancy c1 'function(Q) : "Administration" (key: "fcn") if column A hasn't been previously identified as redundant call...
If .Cells(c1, "A").Value = "" Then fnct_passiveparkuse_redundancy c1 'function(Q) : "Passive Park Use" (key: "fcn") if column A hasn't been previously identified as redundant call...
If .Cells(c1, "A").Value = "" Then facility_league_play_redundancy c1 'facility(I) : "League Play" (key: "fac") if column A hasn't been previously identified as redundant call...
If .Cells(c1, "A").Value = "" Then facility_ring_road_redundancy c1 'facility(I) : "Ring Road" (key: "fac" )if column A hasn't been previously identified as redundant call...
If .Cells(c1, "A").Value = "" Then facility_administration_fee_redundancy c1 'facility(I) : "Administration Fee" (key: "fac") if column A hasn't been previously identified as redundant call...
t_fac = ws_core.Range("H" & c1).Value & ws_core.Range("I" & c1).Value 'complex + facility

' Identify Facilities With No Classification (A, B, C)
msgb = "Redundant records tagged."
msgc = "Assigning facility classifications (A, B, C)."
msg1 = vbLf & msga & vbLf & msgb & vbLf & msgc
uf1_create_wo1.F6E_msg13.Caption = msg1

Debug.Print t_fac
myVal = Application.VLookup(t_fac, ws_fac1.Range("A:C"), 2, False) 'Facility Class (A, B or C)
If IsError(myVal) Then 'if myVal results in an error
ws_core.Range("M" & c1).Value = "X" ' leave an X in column M
If .Cells(c1, "A").Value = "" Then ws_core.Range("A" & c1).Value = "X" ' any blank cells remaining in column A are given X
Else 'no error
ws_core.Range("M" & c1) = myVal ' facility class left in M
End If

' Identify Class C facilities where services haven't been requested.
msgb = "Facility classifications assigned."
msgc = "Identifying Class C service requests."
msg1 = vbLf & msga & vbLf & msgb & vbLf & msgc
uf1_create_wo1.F6E_msg13.Caption = msg1

bv1 = .Cells(c1, "M").Value
bv2 = .Cells(c1, "R").Value
If bv1 = "C" And bv2 <> "Diamond Lining/Preparation Flate Rate" Then 'class C diamonds without a Diamond lining fee applied gets eliminated
If .Cells(c1, "A") = "" Then ws_core.Range("A" & c1).Value = "X2" ' X2 in M
End If
Next c1

msgb = "Class C serviced rentals tagged."
msgc = "Compiling statistics."
msg1 = vbLf & msga & vbLf & msgb & vbLf & msgc
uf1_create_wo1.F6E_msg13.Caption = msg1

End With

red_ref = Application.WorksheetFunction.CountIf(ws_core.Range("A:A"), "ref") 'count of reference eliminations
red_fcn = Application.WorksheetFunction.CountIf(ws_core.Range("A:A"), "fnc") 'count of function eliminations
red_fac = Application.WorksheetFunction.CountIf(ws_core.Range("A:A"), "fac") 'count of facility eliminations
red_class = Application.WorksheetFunction.CountIf(ws_core.Range("A:A"), "X") 'redundant facilities eliminations
red_classc = Application.WorksheetFunction.CountIf(ws_core.Range("A:A"), "X2") 'no service class C eliminations

Debug.Print temp_ws.Name

With temp_ws
.Range("G1") = "REDUNDANCIES"
.Range("G2") = "Reference"
.Range("G3") = "Function"
.Range("G4") = "Facility"
.Range("G5") = "Unid'd Class"
.Range("G6") = "Class C"
.Range("H2") = red_ref
.Range("H3") = red_fcn
.Range("H4") = red_fac
.Range("H5") = red_class
.Range("H6") = red_classc
End With
Workbooks("Sports17.xlsm").Names.Add Name:="redundancy_list", RefersTo:=temp_ws.Range("G2:H6")
Application.ScreenUpdating = True

End Sub[/code]

 

[MARK858]

@Ark68, can you run the code below by Mike Rickson and see if you get the right last row number come up in the message box for each sheet.

Sub trial()
    Dim oneCol As Range
    Dim reallyUsedRows As Range
     
    With ActiveSheet
        Set reallyUsedRows = .UsedRange.Rows(1)
        For Each oneCol In .UsedRange.Columns
            Set reallyUsedRows = Range(reallyUsedRows, oneCol.EntireColumn.Cells(.Rows.Count, 1).End(xlUp))
        Next oneCol
    End With
     
    With reallyUsedRows.SpecialCells(xlCellTypeVisible)
        With .Areas(.Areas.Count)
            MsgBox .Item(.Cells.Count).Row & " is the last visible row"
        End With
    End With
End Sub

 

[Ark68]

Hi Mark,

This macro provided a bit more appropriate results:

'Data' = 41 rows
'Staff' = 18 rows
'Dev' = 5 rows

With worksheet 'Data' though ... it took some noticeable time and taxing the application a bit.

 

[Michael M]

A couple of points to note
Lines like this will slow the code down.....change them to a defined range, not the entire column

.Range("C:C").Value = .Range("F:F").Value

While this may not be an issue, I wouldn't use c1 as a variable....mainly because EXcel might refer to it as a cell reference !!!

For c1 = 2 To llastrow + 1 'populate column J with concat contract+facility+unit
.Range("J" & c1).Value = .Range("C" & c1) & .Range("H" & c1) & .Range("I" & c1)
Next c1

AND
you haven't dimmed llastrow as long

 

[Ark68]

Hi Michael,

I took your advice and cleaned up your observations accordingly. 'llastrow' is publicly declared earlier in my code.
I don't think the suggestions were meant necessarily to resolve the issue, so I'm still at a standstill.
Rather than trying to find the cause, with the results I'm getting, is it possible to even delete the "empty" rows? If I don't do something to reduce this worksheet to a more manageable size, by the end of my project, it's compounded size and effort required to process additional tasks will be a significant challenge.

I had read in my Google searches that sometimes bloated is caused by "formatted" cells. It was a bit over my head and I had a difficult time applying their diagnostics and solutions. For example ...

Fixing bloated file size and slow calculation in Excel | Chandoo.org - Learn Microsoft Excel Online