CODEWITHSUNDEEP
excelvbams-wordsave-as
Mike - SMT
Mike - SMT

Reputation: 15226

Why is the file size growing each time the word document is saved using VBA?

I have a VBA Macro I wrote that takes data from a spreadsheet to generate word documents.

For the most part all the information that is generated is exactly the same except for a few fields that denote contact info and amounts. All the files start out saved at 17kb but as the macro run through the spreadsheet those file sizes grow. After about 2500 saves the files were up to 48kb.

I am not sure why this is happening. I was thinking maybe some kind of meta data is being held onto after each time the doc is deleted and written to again.

I have tried a few things to remove metadata but I am not sure I am doing this correctly as there is not a whole lot out there I could find on this kind of issue.

In an attempt to make this run a little quicker I have build the macro to open a blank word document and then as it loops through all the rows on the spreadsheet is copies the final information to the word doc, SaveAs a unique value in a folder then deletes the content of the word doc and then does the whole thing over again until its iterated through all the rows on the worksheet.

Is there something about how I am generating my files that is causing the growth of the word docx files?

After going into each file that is generated (hundreds) it appears to be growing by 20b on average each new document generated. So the file size slowly but constantly grows each save.

Here is a sample of what the growth looks like over each new document saved.

enter image description here

Here is an example of how the KB are growing over time.

enter image description here

Here is the overall macro stripped down.

Sub GenerateLetterForSelectedMonth()
    Dim temp_wb, data_wb As Workbook
    Dim temp_ws, data_ws As Worksheet
    Dim ltr_str1, ltr_str2, wb_dir, file_path As String
    Dim account_num, cust_name, non_etf_amt, etf_amt, plcmt_amt, mex_act, adr1, adr2, city, state, zip, country, cont_name As String
    Dim last_row1 As Long
    Dim objWord As Object
    ' Dim objWord As New Word.Application
    Dim objDoc As Word.Document
    Dim fd As Office.FileDialog

    Set temp_wb = ActiveWorkbook
    Set temp_ws = temp_wb.Worksheets(1)
    wb_dir = temp_wb.Path

    ' Select file to process '
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    ' open file to process '
    Set data_wb = Workbooks.Open(file_path)
    Set data_ws = data_wb.Worksheets(1)

    ' get last row of file being processed '
    last_row1 = data_ws.Range("A" & data_ws.Rows.Count).End(xlUp).Row

    ' check for todays folder if not exist then create '
    Dim path_ As String
    path_ = wb_dir & "\DOCS " & Format(Now, "MMMM-dd-yyyy")

    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(path_) Then .CreateFolder path_
    End With


    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add
    objWord.Visible = False

    For i = 2 To last_row1

        mex_act = UCase(data_ws.Cells(i, 7).Value)
        account_num = data_ws.Cells(i, 1)
        cust_name = data_ws.Cells(i, 2)
        non_etf_amt = data_ws.Cells(i, 3)
        etf_amt = data_ws.Cells(i, 5)
        plcmt_amt = data_ws.Cells(i, 6)
        adr1 = data_ws.Cells(i, 8)
        adr2 = data_ws.Cells(i, 9)
        city = data_ws.Cells(i, 10)
        state = data_ws.Cells(i, 11)
        zip = data_ws.Cells(i, 12)
        country = data_ws.Cells(i, 13)
        cont_name = WorksheetFunction.Proper(data_ws.Cells(i, 14))

        temp_ws.Cells(3, 1).Value = _
            Format(Now, "MMMM-dd-yyyy") & vbNewLine & cust_name & vbCr & adr1 & " " & adr2 & vbCr & city & ", " & state & " " & zip & vbNewLine & _
            "redacted for post " & "****" & Mid(account_num, 5, 10) & vbNewLine & "Dear " & cont_name & ":" & vbNewLine & "redacted for post" & plcmt_amt & _
            "redacted for post" & vbNewLine & "redacted for post" & non_etf_amt & vbCr & "redacted for post" & etf_amt & vbNewLine & "redacted for post" _

        'Copy the range Which you want to paste in a New Word Document
        temp_ws.Range("A2:A6").Copy

        With objWord
            .Selection.WholeStory
            .Selection.Paste
            .DefaultTableSeparator = " "
        End With

        objWord.ActiveDocument.RemoveDocumentInformation (wdRDIAll)
        objDoc.SaveAs Filename:=path_ & "\" & data_ws.Cells(i, 1)

        With objWord
            objDoc.Range(0, 0).Select
            .Selection.WholeStory
            .Selection.Delete
        End With
        Debug.Print (i)
    Next i

    objWord.Quit SaveChanges:=wdDoNotSaveChanges

End Sub

Upvotes: 0

Views: 262

Answers (1)

Mike - SMT
Mike - SMT

Reputation: 15226

After some guess work I did figure out at least what object was holding onto date each time the file was saved.

I ended up having to completly close and set to Nothing the objDoc and then re add the objDoc each run of the loop. This got rid of the growth of the file size I was looking at.

I still do not know why it was growing so if someone know that bit I would love to know for sure why it happened and not just what it was happening to.

The new code if anyone is interested is below:

Sub GenerateLetterForSelectedMonth()
    Dim temp_wb, data_wb As Workbook
    Dim temp_ws, data_ws As Worksheet
    Dim ltr_str1, ltr_str2, wb_dir, file_path As String
    Dim account_num, cust_name, non_etf_amt, etf_amt, plcmt_amt, mex_act, adr1, adr2, city, state, zip, country, cont_name As String
    Dim last_row1 As Long
    Dim objWord As Object
    ' Dim objWord As New Word.Application
    Dim objDoc As Word.Document
    Dim fd As Office.FileDialog

    Set temp_wb = ActiveWorkbook
    Set temp_ws = temp_wb.Worksheets(1)
    wb_dir = temp_wb.Path

    ' Select file to process '
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    ' open file to process '
    Set data_wb = Workbooks.Open(file_path)
    Set data_ws = data_wb.Worksheets(1)

    ' get last row of file being processed '
    last_row1 = data_ws.Range("A" & data_ws.Rows.Count).End(xlUp).Row

    ' check for todays folder if not exist then create '
    Dim path_ As String
    path_ = wb_dir & "\DOCS " & Format(Now, "MMMM-dd-yyyy")

    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(path_) Then .CreateFolder path_
    End With


    Set objWord = CreateObject("Word.Application")

    For i = 2 To last_row1
        Set objDoc = objWord.Documents.Add ' ADDED THIS LINE
        mex_act = UCase(data_ws.Cells(i, 7).Value)
        account_num = data_ws.Cells(i, 1)
        cust_name = data_ws.Cells(i, 2)
        non_etf_amt = data_ws.Cells(i, 3)
        etf_amt = data_ws.Cells(i, 5)
        plcmt_amt = data_ws.Cells(i, 6)
        adr1 = data_ws.Cells(i, 8)
        adr2 = data_ws.Cells(i, 9)
        city = data_ws.Cells(i, 10)
        state = data_ws.Cells(i, 11)
        zip = data_ws.Cells(i, 12)
        country = data_ws.Cells(i, 13)
        cont_name = WorksheetFunction.Proper(data_ws.Cells(i, 14))

        temp_ws.Cells(3, 1).Value = _
            Format(Now, "MMMM-dd-yyyy") & vbNewLine & cust_name & vbCr & adr1 & " " & adr2 & vbCr & city & ", " & state & " " & zip & vbNewLine & _
            "redacted for post " & "****" & Mid(account_num, 5, 10) & vbNewLine & "Dear " & cont_name & ":" & vbNewLine & "redacted for post" & plcmt_amt & _
            "redacted for post" & vbNewLine & "redacted for post" & non_etf_amt & vbCr & "redacted for post" & etf_amt & vbNewLine & "redacted for post" _

        'Copy the range Which you want to paste in a New Word Document
        temp_ws.Range("A2:A6").Copy

        With objWord
            .Selection.WholeStory
            .Selection.Paste
            .DefaultTableSeparator = " "
        End With

        objWord.ActiveDocument.RemoveDocumentInformation (wdRDIAll)
        objDoc.SaveAs Filename:=path_ & "\" & data_ws.Cells(i, 1)
        objDoc.Close  ' ADDED THIS LINE
        Set objDoc = Nothing  ' ADDED THIS LINE

    Next i

    objWord.Quit SaveChanges:=wdDoNotSaveChanges

End Sub

Upvotes: 0

Related Questions