• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

How to Transfer Data from One Excel Workbook to Another Automatically

narsing rao

Member
Hello,

I have created macro which create report and copy the data into another sheet in the same excel file. but i need the newly created data should be copied on to the desktop in a excel file with name FINTR.we use networked computers so who ever login and do the report report should copied onto there desktop.i found some code but its not working for me.
copying data :\
---------------------
Code:
Public Sub SaveToDesktop()
Dim LoginName As String
LoginName = UCase(GetUserID)

ChDir "C:\Users\" & LoginName & "\Desktop\"
Debug.Print LoginName
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    "C:\Users\" & LoginName & "\Desktop\FINTR.xlsx", Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
    True
End Sub

my macro code:
Code:
Sub Macro1FINTR2()
'
' Macro1FINTR2 Macro
'

'
    Cells.Select
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlLTR
        .MergeCells = False
    End With
    Rows("1:1").Select
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    Columns("P:P").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "P"
    Range("P2").Select
    ActiveCell.FormulaR1C1 = "=LEFT(RC[-2],FIND(""d"",RC[-2],1)-1)"
    Range("P2").Select
    Selection.AutoFill Destination:=Range("P2:P15523")
    Range("P2:P15523").Select
    Columns("Q:Q").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("Q1").Select
    ActiveCell.FormulaR1C1 = "Q"
    Range("Q2").Select
    ActiveCell.FormulaR1C1 = "=VALUE(RC[-1])"
    Range("Q2").Select
    Selection.AutoFill Destination:=Range("Q2:Q15523")
    Range("Q2:Q15523").Select
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$S$15523").AutoFilter Field:=8, Criteria1:=Array( _
        "Accept and close", "AutoClosed after Alert", "Open", "Take Ownership"), Operator _
        :=xlFilterValues
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlLTR
        .MergeCells = False
    End With
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlLTR
        .MergeCells = False
    End With
    Columns("L:L").EntireColumn.AutoFit
    Columns("M:M").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "FINTR"
    Range("A2").Select
End Sub

please help
 
Am sure below code is recorded one where lot of changes required!
Highlighted text in green can be removed to shorten your code!

Code:
Sub Macro1FINTR2()
'
' Macro1FINTR2 Macro
'

'
  Cells.Select
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlLTR
        .MergeCells = False
    End With
    Rows("1:1").Select

'Below 6 LINES NOT REQUIRED
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    Columns("P:P").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "P"
    Range("P2").Select
    ActiveCell.FormulaR1C1 = "=LEFT(RC[-2],FIND(""d"",RC[-2],1)-1)"
    Range("P2").Select
    Selection.AutoFill Destination:=Range("P2:P15523")
    Range("P2:P15523").Select
    Columns("Q:Q").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("Q1").Select
    ActiveCell.FormulaR1C1 = "Q"
    Range("Q2").Select
    ActiveCell.FormulaR1C1 = "=VALUE(RC[-1])"
    Range("Q2").Select
    Selection.AutoFill Destination:=Range("Q2:Q15523")
    Range("Q2:Q15523").Select
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Rows("1:1").Select
    Selection.AutoFilter
'155523 is not dynamic tomarrow data range changes this will not work

    ActiveSheet.Range("$A$1:$S$15523").AutoFilter Field:=8, Criteria1:=Array( _
        "Accept and close", "AutoClosed after Alert", "Open", "Take Ownership"), Operator _
        :=xlFilterValues
    Range("A1").Select

'THIS IS NOT THE WAY TO SELECT THE DATA

    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlLTR
        .MergeCells = False
    End With
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlLTR
        .MergeCells = False
    End With
'NO NEED OF FOUR LINES CAN BE DONE IN ONE LINE
    Columns("L:L").EntireColumn.AutoFit
    Columns("M:M").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "FINTR"
    Range("A2").Select
End Sub

Please let us know if you really wanted to learn the coding rather then just finishing your job...This code can be shot.
 
Monty Thanks for your reply..

Yes, this code is created using macros i haven't done any coding part.
i am from the networking background and just started learning macros and VB.
I'm still at learning stage...really appreciate if you can help with me how to do proper coding so that in future i will fallow the same. and please let me know where to add the code witch you have mentioned above.....
 
Hi Monty,

the code is working but i need only FINTR sheet to be copied on the desktop but this code copying entire worksheet with raw data.

upload_2017-2-17_14-17-58.png

Narsing Rao
 
Mr Narsinng!

Try this

Code:
Sub test()
Application.DisplayAlerts = False
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
ActiveSheet.SaveAs Path & "FINTR.xlsx"
Application.DisplayAlerts = True
End Sub
 
Hi Monty,

still its copying entire sheet with raw data.. i need only FINTR sheet to be copied on desktop as shown in msg 29.

Thanks..
 
Code:
Messages:336
Mr Narsinng!

Try this

Code (vb):
Sub test()
Application.DisplayAlerts = False
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Worksheet("FINTR").SavecopyAs Path & "FINTR.xlsx"
Application.DisplayAlerts = True
End Sub
 
Try this!

Code:
Sub test()
Application.DisplayAlerts = False
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Worksheets("FINTR").Copy
ActiveWorkbook.SaveAs Path & "FINTR.xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
 
Back
Top