Macro to generate a file from another

[Dileep Chandran]

Hi,

Does anybody knows a macro to generate an excel file "B" from an excel
file "A" by pasting all data in file "A" as values and save in desktop?
(only sheet1)

Thanks in advance
-Dileep

 

[Ron de Bruin]

Try this for the activesheet
It save the file on your desktop

Sub Copy_ActiveSheet()
Dim wb As Workbook
Dim strdate As String
Dim WshShell As Object
Dim SpecialPath As String

Set WshShell = CreateObject("WScript.Shell")
SpecialPath = WshShell.SpecialFolders("Desktop")

strdate = Format(Now, "dd-mm-yy h-mm-ss")
Application.ScreenUpdating = False

ActiveSheet.Copy
Set wb = ActiveWorkbook

With wb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False

With wb
.SaveAs SpecialPath & "\Part of " & ThisWorkbook.Name _
& " " & strdate & ".xls"
.Close False
End With
Application.ScreenUpdating = True
End Sub

 

[Dileep Chandran]

Thanks Ron, It works awesome. Is it possible to copy the informations
to a specified sheet in a specified file stored in a network drive?

Thanks again for the timely help

-Dileep

 

[Dileep Chandran]

Thank You, Martin......

 

[Ron de Bruin]

Yes this is possible

Do you want to copy a range to the workbook stored in a network drive
in a hard coded destination cell ?

 

[Dileep Chandran]

Yes Ron. You got it right.

 

[Ron de Bruin]

You can try this basic example

First it check if test.xls is open
If not open in open H:\test.xls

Then it copy the range from the workbook with the code (thisworkbook)
Worksheets("Sheet1").Range("A1:C10")

To A1 in "Sheet1" of H:\test.xls
destWB.Worksheets("Sheet1").Range("A1")

After that it save test.xls and close it


Sub copy_to_another_workbook()
Dim sourceRange As Range
Dim destrange As Range
Dim destWB As Workbook

Application.ScreenUpdating = False
If bIsBookOpen("test.xls") Then
Set destWB = Workbooks("test.xls")
Else
Set destWB = Workbooks.Open("H:\test.xls")
End If
Set sourceRange = ThisWorkbook.Worksheets("Sheet1").Range("A1:C10")
Set destrange = destWB.Worksheets("Sheet1").Range("A1")
sourceRange.Copy
destrange.PasteSpecial xlPasteValues, , False, False
Application.CutCopyMode = False
destWB.Close True
Application.ScreenUpdating = True
End Sub


'Copy this function also in the module

Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function

 

[Dileep Chandran]

This sorted out all my issues. Thank you, Ron.

-Dileep

 

[Dileep Chandran]

Hey Ron,

One small clarification needed. Is it possible to change the code

Set sourceRange = ThisWorkbook.Worksheets("Sheet1").Range("A1:C10")

to a specified file in the users' desktop?

What I need is to change the source range to "Sheet1" in the file
"Test.xls" saved in the users desktop.

Thank you for your help.

-Dileep Chandran

 

[Chip Pearson]

Dileep,

You need to use Windows API calls to find the Desktop folder for the current
user. I have code on my website that handles all this for you, not just for
the Desktop folder but all special folders like History, Favorites, and
MyDocuments. You just pass in an identifier indicating which special folder
you want, and the function return the correct full folder name.

See http://www.cpearson.com/excel/SpecialFolders.htm for example code.

Download and import the code module
http://www.cpearson.com/Zips/modGetUserDirectory.zip
from that page into your project, and then use code like the following to
get the folder to the user's desktop:

Function GetDeskTopFolder() As String
''''''''''''''''''''''''''''''''''''''
' GetDeskTopFolder
' Returns the folder of the desktop
' for the current user.
''''''''''''''''''''''''''''''''''''''
Dim CSIDL As Long
CSIDL = CSIDL_DESKTOP
GetDeskTopFolder = F_7_AB_1_GetSpecialFolder(CSIDL_DESKTOP)
End Function

This function will return the path of the user's desktop folder. You can
then use that function in code like the following:

Sub OpenFileOnDesktop()
Dim DesktopFolder As String
Dim FName As String
Dim WB As Workbook
FName = "Test.xls" '<<<< CHANGE AS NEEDED
DesktopFolder = GetDeskTopFolder()
Set WB = Workbooks.Open(DesktopFolder & "\" & FName)
Debug.Print WB.FullName
End Sub

Sub SaveToDesktop()
Dim DesktopFolder As String
Dim FName As String
Dim WB As Workbook
FName = "Test.xls" '<<<< CHANGE AS NEEDED
DesktopFolder = GetDeskTopFolder()
ActiveWorkbook.SaveAs DesktopFolder & "\" & FName
Debug.Print ActiveWorkbook.FullName
End Sub


--
Cordially,
Chip Pearson
Microsoft MVP - Excel
Pearson Software Consulting, LLC
www.cpearson.com
(email address is on the web site)