Preserve formatting for mail merge Excel & Word 2016

Question

I inherited some code and have discovered that it seems incredibly inefficient. The code works by applying text formatting to the cells in an Excel file cell by cell, via this loop:

Public Sub RemoveNumberFormat(ByVal columnName As String, ByVal lastColumn As Integer)
    For i = 2 To lastColumn
        textval = Range(columnName & CStr(i)).Text
        Range(columnName & CStr(i)).NumberFormat = "@"
        Range(columnName & CStr(i)).Value = textval
    Next i
End Sub

This will preserve numbers such as 6120 as 6,120 and currency values such as 7568910 as $7,568,910. These numbers are brought in from the Excel workbook into mail merge fields in a Word document. Currently, this function is called on every column in the workbook like so:

    RemoveNumberFormat "AM", lastColumn
    RemoveNumberFormat "AU", lastColumn
    RemoveNumberFormat "AV", lastColumn
    RemoveNumberFormat "BA", lastColumn
    ... etc.

Now this does work, but there's 145 columns. The macro is called on open and it takes several seconds to run. This seems incredibly inefficient.

I had tried simply updating the NumberFormat of the UsedRange as so:

Sheets("MailMerge").UsedRange.NumberFormat = "@"

But that still removes the commas and currency formatting from the columns.

I had also tried copying the values, updating the NumberFormat, then pasting the values in (essentially re-creating that loop as a set operation rather than cell by cell) but that also did not result in the formatting being preserved.

Is there a better way to do this than loop through each cell?

Answer 1

You can't read the Text property from a multi-cell range the same way you can with (eg) Value, but you can change the number format and set the value for the whole block using only two single operations, so something like this is much faster:

Public Sub RemoveNumberFormat2(ByVal columnName As String, _
                               ByVal lastColumn As Integer)
    Dim d(), rng As Range, i As Long

    Set rng = Range(columnName & "2:" & columnName & lastColumn)

    ReDim d(1 To lastColumn - 1, 1 To 1)

    'read the text values: this you have to do in a loop...
    For i = 1 To rng.Cells.Count
        d(i, 1) = rng(i).Text
    Next i

    'these you can do as a block...
    With rng
        .NumberFormat = "@"
        .Value = d
    End With
End Sub

In my testing on a ~3000-row column this was about 10x faster.