Excel VBA Copy Formulas and Number Formats

[Biz]

Hi,

I have code which copies formulas from another Excel Workbook but fails to copy Number Formats.

Sub CopyFormulas_From_AnotherWorkbook()
1     Dim bOpen As Boolean
2     Dim arArray(), formatArray()
3     Dim rTable As Range
4     Dim rTarget As Range
5     Dim sFileName
6     Dim Wb As Workbook
      Dim wbSource As Workbook
      Dim wbDest As Workbook
       
7     On Error Resume Next
      '~~> The user to select the range that needs to be copied
8     Set rTable = Application.InputBox(Prompt:="Select the range to copy.", Title:="Select range", Default:=Selection.Address, Type:=8)
      
      '~~> Checks if user has selected a range
9     If Not rTable Is Nothing Then
10        On Error GoTo ErrorHandle
            
11        If rTable.Count = 1 Then
12            MsgBox "There must be more than 1 cell"
13            GoTo BeforeExit
14        End If
            
        '~~> Copies the formulas to an array. The array will automatically get the same
        'dimensions as the range. The trick to get the formulas is to write'"rTable.Formula".

15        arArray = rTable.Formula
          
            
            '~~> Show a file open dialogue. Select the target workbook. This doesn't open
            'the workbook, it just returns the file name and the path.
            
16        sFileName = Application.GetOpenFilename("Excel files (*.xls*),*.xls*", , "Select the target workbook")
            
17        If sFileName = False Then GoTo BeforeExit
            
            '~~> If there is more than one open workbook,we check if it is already open. If it is, we just activate it.
18        For Each Wb In Workbooks
19            If Wb.FullName = sFileName Then
20                Wb.Activate
21                bOpen = True
22                Exit For
23            End If
24        Next
            
            '~~> If the target workbook isn't open, we open it
25        If bOpen = False Then
26            Workbooks.Open (sFileName)
27        End If
            
28        On Error Resume Next
            
            '~~> Ask the user to select insertion point
29        Set rTarget = Application.InputBox(Prompt:="Select cell for the table's upper left corner", Title:="Select target", Default:=Selection.Address, Type:=8)
           Call CopyFormats(wbSource, rTable, wbDest, rTarget)
            
            '~~> If the user selected a cell
30        If Not rTarget Is Nothing Then
31            On Error GoTo ErrorHandle
                
                '~~> Dimension the range to the same dimensions(rows, columns) as the array.
32            Set rTable = rTarget.Resize(UBound(arArray), UBound(arArray, 2))
                '~~> Paste the formulas
33            rTable.Formula = arArray
              'rTable.Copy
              'rTarget.PasteSpecial Paste:=xlPasteFormats

34        End If
35    End If
    

BeforeExit:
36    On Error Resume Next
37    Set rTable = Nothing
38    Set rTarget = Nothing
39    Erase arArray
        
40    Exit Sub
ErrorHandle:
41    MsgBox Err.Description
42    Resume BeforeExit
End Sub
Sub CopyFormats(wbSource As Workbook, rTable As Range, wbDest As Workbook, rTarget As Range)

Windows(wbSource).Activate
    rTable.Copy
    Windows(wbDest).Activate
    rTarget.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

End Sub

Your help would be greatly appreciated.


Kind Regards


Biz

 

[Zot]

In your main routine Sub CopyFormulas_From_AnotherWorkbook(), I can see you have
Dim wbSource As Workbook
Dim wbDest As Workbook

but I did not see where you defined them. However, you passed the parameters when you Call CopyFormats(wbSource, rTable, wbDest, rTarget).

I guess you did not actually copy any format to transfer over.

 

[Alex Blakenburg]

As @Zot pointed out this line is not doing anything because most of the parameters are not being set.

           Call CopyFormats(wbSource, rTable, wbDest, rTarget)

You can slightly modify the code that follows to copy the values and formats.
You were switched rTable from being the source to being the destination and you needed both to make the copy part work.

                '~~> Dimension the range to the same dimensions(rows, columns) as the array.
              Dim destTable As Range
32            Set destTable = rTarget.Resize(UBound(arArray), UBound(arArray, 2))
                '~~> Paste the formulas
33            destTable.Formula = arArray
            ' XXX Uncomment the next 2 lines
              rTable.Copy
              rTarget.PasteSpecial Paste:=xlPasteFormats

If you didn't want "all" the formats but just the number formats you didn't need the arArray code at all and could have just gone with:

                '~~> Paste the formulas
33            destTable.Formula = arArray ' REMOVE
            ' XXX Uncomment the next 2 lines
              rTable.Copy
              rTarget.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats

 

[Biz]

Thank you for your prompt responses. I will try it out and let you know how it goes.

 

[Biz]

Thank you Zot & Alex.

Please find below my revised code which works.

Sub CopyFormulas_From_AnotherWorkbook()
1     Dim bOpen As Boolean
2     Dim arArray(), formatArray()
3     Dim rTable As Range
4     Dim rTarget As Range
5     Dim sFileName
6     Dim Wb As Workbook
7     Dim wbSource As Workbook
8     Dim wbDest As Workbook
       
9     On Error Resume Next
      '~~> The user to select the range that needs to be copied
10    Set rTable = Application.InputBox(Prompt:="Select the range to copy.", Title:="Select range", Default:=Selection.Address, Type:=8)
        
        '~~> Checks if user has selected a range
11    If Not rTable Is Nothing Then
12        On Error GoTo ErrorHandle
            
13        If rTable.Count = 1 Then
14            MsgBox "There must be more than 1 cell"
15            GoTo BeforeExit
16        End If
            
            '~~> Copies the formulas to an array. The array will automatically get the same
            'dimensions as the range. The trick to get the formulas is to write'"rTable.Formula".
            
17        arArray = rTable.Formula
18        Set wbSource = Workbooks(rTable.Parent.Parent.Name)
            
            '~~> Show a file open dialogue. Select the target workbook. This doesn't open
            'the workbook, it just returns the file name and the path.
            
19        sFileName = Application.GetOpenFilename("Excel files (*.xls*),*.xls*", , "Select the target workbook")
            
20        If sFileName = False Then GoTo BeforeExit
            
            '~~> If there is more than one open workbook,we check if it is already open. If it is, we just activate it.
21        For Each Wb In Workbooks
22            If Wb.FullName = sFileName Then
23                Wb.Activate
24                bOpen = True
25                Exit For
26            End If
27        Next
            
            '~~> If the target workbook isn't open, we open it
28        If bOpen = False Then
29            Workbooks.Open (sFileName)
30        End If
            
31        On Error Resume Next
            
            '~~> Ask the user to select insertion point
32        Set rTarget = Application.InputBox(Prompt:="Select cell for the table's upper left corner", Title:="Select target", Default:=Selection.Resize(1, 1).Address, Type:=8)
33        Set wbDest = Workbooks(rTarget.Parent.Parent.Name)
            
            '~~> Copying Source Formatting only
34        Call CopyFormats(wbSource, rTable, wbDest, rTarget)
            
            '~~> If the user selected a cell
35        If Not rTarget Is Nothing Then
36            On Error GoTo ErrorHandle
                
                '~~> Dimension the range to the same dimensions(rows, columns) as the array.
37            Set rTable = rTarget.Resize(UBound(arArray), UBound(arArray, 2))
                '~~> Paste the formulas
38            rTable.Formula = arArray
                
39        End If
40    End If
        
BeforeExit:
41    On Error Resume Next
42    Set rTable = Nothing
43    Set rTarget = Nothing
44    Erase arArray
        
45    Exit Sub
ErrorHandle:
46    MsgBox Err.Description
47    Resume BeforeExit
End Sub

Sub CopyFormats(wbSource As Workbook, rTable As Range, wbDest As Workbook, rTarget As Range)
     
1    wbSource.Sheets(rTable.Parent.Name).Range(rTable.Address).Copy
2    wbDest.Sheets(rTarget.Parent.Name).Range(rTarget.Address).PasteSpecial Paste:=xlPasteFormats
3    Application.CutCopyMode = False
      
      
End Sub

Kind Regards
Biz

 

[Alex Blakenburg]

Thanks for the feedback. Glad we could help.