Friday, December 25, 2009

Programatically copy worksheet via VBA in Excel

Dim oBook As Workbook

Excel.Application.DisplayAlerts = False

Application.ScreenUpdating = False

Me.btnExportWorkSheet.TakeFocus<nClick = False

' Delete the Old File

Kill "c:\FileName.xls"

' Create a new blank workbook:

Set oBook = Application.Workbooks.Add

Application.SheetsInNewWorkbook = 1

' Add a defined name to the workbook

' that RefersTo a range:

oBook.Names.Add Name:="tempRange", RefersTo:="=Sheet1!$A$1"


' Save the workbook:

oBook.SaveAs "c:\FileName.xls"


' Select the Workbook where the Worksheet to be copied is located

Workbooks("Old File.xls").Activate

Workbooks("Old File.xls").Worksheets("Work Sheet A").Activate


' Copy the Worksheet to the Workbook

Worksheets("Work Sheet A").Copy Before:=Workbooks("New Work

Book.xls").Sheets(1)

Dim xRange As Range, adr As String

Workbooks("New Work Book.xls").Worksheets("Work Sheet A").Activate

Workbooks("New Work Book.xls").Worksheets("Work Sheet A").Range("a1:z100").Activate

' Remove Links and Replace with Cell Values

With Workbooks("New Work Book.xls").Worksheets("Work Sheet A")

Dim cCell As Range

Dim strValue As String

Set xRange = .Range("a1:z100")

For Each cCell In xRange

' Save the value to use as a means to identify what cells

to change

strValue = CStr(cCell.Value)

If InStr(strValue, "/") > 0 Then

cCell = CStr(cCell.Value)

End If

Next

End With

' Select the next Workbook where the Worksheet to be copied is located

Workbooks("Old File.xls").Activate

Workbooks("Old File.xls").Worksheets("Work Sheet B").Activate

' Copy the Worksheet to the Workbook

Worksheets("Work Sheet B").Copy Before:=Workbooks("CashFlowInput&DollarChart.xls").Sheets(1) ', UpdateLinks:=0

Workbooks("New Work Book.xls").Worksheets("Work Sheet B").Activate

Workbooks("New Work Book.xls").Worksheets("Work Sheet B").Range("a1:z100").Activate

' Remove Links and Replace with Cell Values

With Workbooks("New Work Book.xls").Worksheets("Dollars Chart")

Set xRange = .Range("a1:z100")

For Each cCell In xRange

' Save the value to use as a means to identify what cells to change

' cCell.Formula will show the link back to the Original

Workbook

strValue = CStr(cCell.Formula)

If InStr(strValue, "!") > 0 Then

cCell = CStr(cCell.Value)

' If cCell = .Range("b51") Or cCell = .Range("m4") Then

' Stop

' End If

End If

Next

End With

MsgBox ("Your Worksheets have been copied to C:\New Work Book.xls")

End Sub

No comments:

Post a Comment