Hi,
I have code which copies formulas from another Excel Workbook but fails to copy Number Formats.
Your help would be greatly appreciated.
Kind Regards
Biz
I have code which copies formulas from another Excel Workbook but fails to copy Number Formats.
Rich (BB code):
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