[Last Call] Learn about multicloud storage options and how to improve your company's cloud strategy. Register Now

x
?
Solved

adjust a macro that selects the latest file in a folder and sends an email of a specific worksheet

Posted on 2012-12-28
27
1 solution
Medium Priority
?
340 Views
Last Modified: 2013-01-10
The following code was written for me by TheBarman on the 29thSep
It does the following:
1. selects the last file in a folder
2. selects a sheetA from the file
3. sends an email of sheetA

I would like to amend the macro so that it:
1. selects the last file in a folder
2. selects a sheetA from the file
3. copies the sheetA to another file in another folder. FolderB/B.xls/sheetA

So a much simpler macro as it does not need to dens the email.

ALSO, I would like the file with the macro to be in FolderB, not in the FolderA where the files are stored.


Public Sub MailLatestSheet()

Dim strPath As String: strPath = ThisWorkbook.Path
Dim objFS As Object, objFolder As Object
Dim objFi As Object, objFolders As Object
Dim objFiles As Object, objF1 As Object
Dim strFileName As String, strFolder As String, arrfolder
Dim FileLen As Integer, wbF As Workbook
Dim lngFileNumb As Long

Application.ScreenUpdating = False

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFiles = objFolder.Files
    For Each objF1 In objFiles
        If Right(objF1.Name, 3) = "xls" Then
            If IsNumeric(Left(objF1.Name, 8)) Then
                If lngFileNumb < CLng(Left(objF1.Name, 8)) Then
                    lngFileNumb = CLng(Left(objF1.Name, 8))
                    strFileName = objF1.Name
                End If
            End If
        End If
    Next

Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing

'set variables here for Mailing *File* , *Sheetname* , *Address*
Call Mail_Sheets(strPath & "\" & strFileName, "A", "SomeOne@SomeWhere.com")

Application.ScreenUpdating = True
'MsgBox "Mail Sent", vbCritical, "Macro Complete"
End Sub

Sub Mail_Sheets(txtSourcewb As String, shtName As String, mAddress As String)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object

    Set Sourcewb = Workbooks.Open(txtSourcewb, , True)
 
' Next, copy the sheet to a new workbook.
' You can also use the following line, instead of using the ActiveSheet object,
' if you know the name of the sheet you want to mail :
    Sourcewb.Sheets(shtName).Copy

    Set Destwb = ActiveWorkbook

    ' Determine the Excel version, and file extension and format.
    With Destwb
        If Val(Application.Version) < 12 Then
            ' For Excel 2000-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            ' For Excel 2007-2010, exit the subroutine if you answer
            ' NO in the security dialog that is displayed when you copy
            ' a sheet from an .xlsm file with macros disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "You answered NO in the security dialog."
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With

    ' You can use the following statements to change all cells in the
    ' worksheet to values.
    '
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '
    '    Application.CutCopyMode = False
    '
    ' Save the new workbook, mail, and then delete it.
    TempFilePath = Environ$("temp") & "\"
   
    'create new name for attachment
    TempFileName = "Part of " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")

    Set OutApp = CreateObject("Outlook.Application")
   
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
       ' Change the mail address and subject in the macro before
       ' running the procedure.
        With OutMail
            .To = mAddress
            .CC = ""
            .BCC = ""
            .Subject = "Here is your tab" & shtName
            .Body = "Hi – your worksheet is attached. Enjoy!"
            .Attachments.Add Destwb.FullName
            ' You can add other files by uncommenting the following statement.
            '.Attachments.Add ("C:\test.txt")
            ' In place of the following statement, you can use ".Display" to
            ' display the mail.
            .Send
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    ' Delete the file after sending.
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub
0
Comment
Question by:CC10
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
Join The Community
  • 14
  • 13
27 Comments
 
LVL 24

Expert Comment

by:Steve
ID: 38727734
Hi there CC, I am currently in an internet free household for the festive season (the in-laws).

I am sure others here will be able to fix this for you.
Otherwise I will happily do the change when I get back to modern times :)
0
 

Author Comment

by:CC10
ID: 38730606
OK Thanks.  All the best for 2013.
0
 
LVL 24

Expert Comment

by:Steve
ID: 38731644
OK, have had some spare time to look at this one, have written the code in notepad so it has not been tested (yet). Have just tested and it looks OK, but may need tweaks to fit your specific needs for file saveAs name. Let me know what you require.

If you have a look and see if it makes sense or if there are changes required:
Public Sub MailLatestSheet()

Dim strPath As String: strPath = ThisWorkbook.Path
Dim objFS As Object, objFolder As Object
Dim objFi As Object, objFolders As Object
Dim objFiles As Object, objF1 As Object
Dim strFileName As String, strFolder As String, arrfolder
Dim FileLen As Integer, wbF As Workbook
Dim lngFileNumb As Long

Application.ScreenUpdating = False

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFiles = objFolder.Files
    
    For Each objF1 In objFiles
        If Right(objF1.Name, 3) = "xls" Then
            If IsNumeric(Left(objF1.Name, 8)) Then
                If lngFileNumb < CLng(Left(objF1.Name, 8)) Then
                    lngFileNumb = CLng(Left(objF1.Name, 8))
                    strFileName = objF1.Name
                End If
            End If
        End If
    Next

Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing

'set variables here for Mailing *SourceFile* , *Sheetname* , *Address*
'Call Mail_Sheets(strPath & "\" & strFileName, "A", "SomeOne@SomeWhere.com")

'set variables here for Copying *SourceFile* , *Sheetname* , *DestinationFile*
Call CopySheetToNewWorkbook(strPath & "\" & strFileName, "A",strPath & "\" & "newFileName.xls")

Application.ScreenUpdating = True
'MsgBox "Mail Sent", vbCritical, "Macro Complete"
End Sub

sub CopySheetToNewWorkbook(txtSourcewb As String, shtName As String, txtDestinationwb As String)

Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object

    Set Sourcewb = Workbooks.Open(txtSourcewb, , True)
  
' Next, copy the sheet to a new workbook.
' You can also use the following line, instead of using the ActiveSheet object,
' if you know the name of the sheet you want to mail :
    Sourcewb.Sheets(shtName).Copy

    Set Destwb = ActiveWorkbook

    ' Determine the Excel version, and file extension and format.
    With Destwb
        If Val(Application.Version) < 12 Then
            ' For Excel 2000-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            ' For Excel 2007-2010, exit the subroutine if you answer
            ' NO in the security dialog that is displayed when you copy
            ' a sheet from an .xlsm file with macros disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "You answered NO in the security dialog."
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With

    ' You can use the following statements to change all cells in the
    ' worksheet to values.
    '
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '
    '    Application.CutCopyMode = False
    '
    ' Save the new workbook.

    With Destwb
        .SaveAs txtDestinationwb, FileFormat:=FileFormatNum
        .close
    end with

End sub

Open in new window

0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Take Survey Now!
 

Author Comment

by:CC10
ID: 38732725
Terrific...That works fine but there are two changes that I would like if possible.

1. The macro should be in another folder.
The folder where all the files are is called FolderA
The file that includes the macro should be in a separate folder named FolderY, workbookY, macroSub.....
Therefore the macro should search for the last file in FolderA
2. at the moment the new file with the copied sheet appears in Folder A. The sheet should be copied to an existing file: FolderY, workbookZ, Sheet"A". The copied file will always replace sheet"A".

Does that make sense?

Thanks,
CC
0
 
LVL 24

Expert Comment

by:Steve
ID: 38733049
1) if you wish to move the macro file but point to another folder change the following line (line 3 of the code):
Dim strPath As String: strPath = ThisWorkbook.Path

Open in new window

to the location of the files (for example):
Dim strPath As String: strPath = "C:\Users\Steve\Desktop"

Open in new window


2) the output file is determined by the following line:
Call CopySheetToNewWorkbook(strPath & "\" & strFileName, "A",strPath & "\" & "newFileName.xls")

Open in new window

change this to change the output file (for example):
Call CopySheetToNewWorkbook(strPath & "\" & strFileName, "A","\\FolderY\newFileName.xls")

Open in new window

This will however overwrite the whole file.

If you want to replace the sheet in an existing workbook, this would require a change in approach, I will look at writing the code for this.
0
 
LVL 24

Expert Comment

by:Steve
ID: 38733088
The following code will copy the sheet to an existing workbook:
Will need to change the code to point at the right source and destination files...

Public Sub MailLatestSheet()

Dim strPath As String: strPath = ThisWorkbook.Path
Dim objFS As Object, objFolder As Object
Dim objFi As Object, objFolders As Object
Dim objFiles As Object, objF1 As Object
Dim strFileName As String, strFolder As String, arrfolder
Dim FileLen As Integer, wbF As Workbook
Dim lngFileNumb As Long

Application.ScreenUpdating = False

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFiles = objFolder.Files
    
    For Each objF1 In objFiles
        If Right(objF1.Name, 3) = "xls" Then
            If IsNumeric(Left(objF1.Name, 8)) Then
                If lngFileNumb < CLng(Left(objF1.Name, 8)) Then
                    lngFileNumb = CLng(Left(objF1.Name, 8))
                    strFileName = objF1.Name
                End If
            End If
        End If
    Next

Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing

'set variables here for Copying *SourceFile* , *Sheetname* , *DestinationFile*
Call CopySheetToExistingWorkbook(strPath & "\" & strFileName, "A",strPath & "\" & "newFileName.xls")

Application.ScreenUpdating = True
'MsgBox "Mail Sent", vbCritical, "Macro Complete"
End Sub

sub CopySheetToExistingWorkbook(txtSourcewb As String, shtName As String, txtDestinationwb As String)

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object

    Set Sourcewb = Workbooks.Open(txtSourcewb, , True)
    Set Destwb = Workbooks.Open(txtDestinationwb, , False)

    Sourcewb.Sheets(shtName).Copy Before:=Workbooks(txtDestinationwb).Sheets(1) 

    With Destwb
        .Save
        .close
    end with

End sub

Open in new window


Let me know if you need more tweaks.
0
 

Author Comment

by:CC10
ID: 38737665
Am a bit confused with changing the names:

1. the workbook with the macro should be in:
C:\Users\Centa\Dropbox\Centa\Centa FXDP\Macros\MailFile.xlsm
2. The Folder with all the data files is:
C:\Users\Centa\Dropbox\Centa\Centa FXDP\FXDP daily reports\Fixings
3. The target workbook is:
C:\Users\Centa\Dropbox\Centa\Centa FXDP\Trader Journals\TraderPositionSheet.xlsm
4. The worksheet that should be copied is called MA Risk. There is an identical worksheet in the TraderPositionSheet workbook and the contents could be copied and pasted so as to replace the data each day.

Sorry to be a pain but could you amend the macro?

Thanks,
CC
0
 

Author Comment

by:CC10
ID: 38740705
I am getting there but there is an error at the final line:
  Sourcewb.Sheets(shtName).Copy Before:=Workbooks(txtDestinationwb).Sheets("MA Risk")


Public Sub MailLatestSheet4()

Dim strPath As String: strPath = "C:\Users\Centa\Dropbox\Centa\Centa FXDP\FXDP daily reports\Fixings"
Dim objFS As Object, objFolder As Object
Dim objFi As Object, objFolders As Object
Dim objFiles As Object, objF1 As Object
Dim strFileName As String, strFolder As String, arrfolder
Dim FileLen As Integer, wbF As Workbook
Dim lngFileNumb As Long

Application.ScreenUpdating = False

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFiles = objFolder.Files
   
    For Each objF1 In objFiles
        If Right(objF1.Name, 3) = "xls" Then
            If IsNumeric(Left(objF1.Name, 8)) Then
                If lngFileNumb < CLng(Left(objF1.Name, 8)) Then
                    lngFileNumb = CLng(Left(objF1.Name, 8))
                    strFileName = objF1.Name
                End If
            End If
        End If
    Next

Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing

'set variables here for Copying *SourceFile* , *Sheetname* , *DestinationFile*
'Call CopySheetToExistingWorkbook4(strPath & "\" & strFileName, "A", strPath & "\" & "newFileName.xls")
Call CopySheetToExistingWorkbook4(strPath & "\" & strFileName, "MA Risk", "\\C:Users\Centa\Dropbox\Centa\Centa FXDP\Trader Journals\TraderPositionSheet.xlsm")

Application.ScreenUpdating = True
'MsgBox "Mail Sent", vbCritical, "Macro Complete"
End Sub

Sub CopySheetToExistingWorkbook4(txtSourcewb As String, shtName As String, txtDestinationwb As String)

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object

    Set Sourcewb = Workbooks.Open(txtSourcewb, , True)
    Set Destwb = Workbooks.Open(txtDestinationwb, , False)
   
    Sourcewb.Sheets(shtName).Copy Before:=Workbooks(txtDestinationwb).Sheets("MA Risk")

    With Destwb
        .Save
        .Close
    End With

End Sub
0
 
LVL 24

Expert Comment

by:Steve
ID: 38747198
The before sheet is the sheet before which you would like to put the new sheet (in order of tabs)

So if you leave that as 1 you should be OK. (or change it to the name of a sheet in the destination workbook)
0
 

Author Comment

by:CC10
ID: 38752596
I am not getting anywhere.  I changed the code as follows so that the strPath and newFileName reflected the real names.

'Call CopySheetToExistingWorkbook4(strPath & "\" & strFileName, "A", strPath & "\" & "newFileName.xls")
Call CopySheetToExistingWorkbook4(strPath & "\" & strFileName, "MA Risk", "\\C:Users\Centa\Dropbox\Centa\Centa FXDP\Trader Journals\TraderPositionSheet.xlsm")

But I still get an error in the line:
    Sourcewb.Sheets(shtName).Copy Before:=Workbooks(txtDestinationwb).Sheets("C1")

here the worksheet MA Risk is before the worksheet C1 in the workbook TraderPosition Sheet.
0
 
LVL 24

Expert Comment

by:Steve
ID: 38752911
OK, well, I think the issue is due to the sheet already existing in the new workbook.

This means it all gets a tad more tricky, as any fomual based off the existing sheet will #ref if the old sheet is deleted before the copy to the new workbook.

It may be better to copy paste special values to the new sheet... are there any merged cells in the "MA Risk" sheet?
0
 

Author Comment

by:CC10
ID: 38753848
No, so it would be possible to copy and paste values and formats.

The macro
1.finds the latest workbook in C:\Users\Centa\Dropbox\Centa\Centa FXDP\FXDP daily reports\Fixings
e.g. last night it was: "20130107 Fixing Centa FXDP Report.xls"
2. copies the whole worksheet "MA Risk"  or the range: A1:R80 (this may be better)
3 opens the workbook C:\Users\Centa\Dropbox\Centa\Centa FXDP\Trader Journals\TraderPositionSheet.xlsm
4. selects sheet "MA Risk"
5. pastes values and formats

I will increase the points to 500
0
 

Author Comment

by:CC10
ID: 38753850
x
0
 
LVL 24

Expert Comment

by:Steve
ID: 38753930
You should be able to just change the one line for the copy:

to
Sourcewb.Sheets(shtName).range("A1:R80").Copy Workbooks(txtDestinationwb).Sheets(shtName).range("A1:R80")

Open in new window


this should copy the values from one to the other.
are there formula in the source file? (if so may need to "fix" the values before copy)

If this works can you post the code you have in place and I will look to tidy it up a little too.
0
 
LVL 24

Expert Comment

by:Steve
ID: 38754444
ok, here is a slightly cleaner bit of code:

Public Sub MailLatestSheet()

Dim strPath As String: strPath = "C:\Users\Centa\Dropbox\Centa\Centa FXDP\FXDP daily reports\Fixings\"
Dim objFS As Object, objFolder As Object
Dim objFi As Object, objFolders As Object
Dim objFiles As Object, objF1 As Object
Dim strFileName As String, strFolder As String, arrfolder
Dim FileLen As Integer, wbF As Workbook, DestWb As Workbook
Dim lngFileNumb As Long

Application.ScreenUpdating = False

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFiles = objFolder.Files
    
    For Each objF1 In objFiles
        If Right(objF1.Name, 3) = "xls" Then
            If IsNumeric(Left(objF1.Name, 8)) Then
                If lngFileNumb < CLng(Left(objF1.Name, 8)) Then
                    lngFileNumb = CLng(Left(objF1.Name, 8))
                    strFileName = objF1.Name
                End If
            End If
        End If
    Next

Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing

Set Sourcewb = Workbooks.Open(strPath & objF1.Name, , True)
Set DestWb = Workbooks.Open("C:\Users\Centa\Dropbox\Centa\Centa FXDP\Trader Journals\TraderPositionSheet.xlsm", , False)

Sourcewb.Sheets("MA Risk").Range("A1:R80").Copy DestWb.Sheets("MA Risk").Range("A1:R80")

Application.ScreenUpdating = True

End Sub

Open in new window

0
 

Author Comment

by:CC10
ID: 38756699
I get an error at:
Set Sourcewb = Workbooks.Open(strPath & objF1.Name, , True)
0
 
LVL 24

Expert Comment

by:Steve
ID: 38756739
Lol, my bad, is because I set objF1 to nothing furthur up, oops:

Try
Set Sourcewb = Workbooks.Open(strPath & objF1.Name, , True)

Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing

Open in new window


As I started this one on an unfarmiliar PC I have not set up test files.
So am writing the code without testing.
If you still have issues after this change I will create mock workbooks and get it sorted once and for all :)
0
 

Author Comment

by:CC10
ID: 38756893
Hi there, am really sorry but now get an error at
Set Sourcewb = Workbooks.Open(strPath & objF1.Name, , True

It is in  twice

here is the code that I am now using:
Public Sub MailLatestSheet6()

Dim strPath As String: strPath = "C:\Users\Centa\Dropbox\Centa\Centa FXDP\FXDP daily reports\Fixings\"
Dim objFS As Object, objFolder As Object
Dim objFi As Object, objFolders As Object
Dim objFiles As Object, objF1 As Object
Dim strFileName As String, strFolder As String, arrfolder
Dim FileLen As Integer, wbF As Workbook, DestWb As Workbook
Dim lngFileNumb As Long

Application.ScreenUpdating = False

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFiles = objFolder.Files
   
    For Each objF1 In objFiles
        If Right(objF1.Name, 3) = "xls" Then
            If IsNumeric(Left(objF1.Name, 8)) Then
                If lngFileNumb < CLng(Left(objF1.Name, 8)) Then
                    lngFileNumb = CLng(Left(objF1.Name, 8))
                    strFileName = objF1.Name
                End If
            End If
        End If
    Next


Set Sourcewb = Workbooks.Open(strPath & objF1.Name, , True)
Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing

Set Sourcewb = Workbooks.Open(strPath & objF1.Name, , True)
Set DestWb = Workbooks.Open("C:\Users\Centa\Dropbox\Centa\Centa FXDP\Trader Journals\TraderPositionSheet.xlsm", , False)

Sourcewb.Sheets("MA Risk").Range("A1:R80").Copy DestWb.Sheets("MA Risk").Range("A1:R80")

Application.ScreenUpdating = True

End Sub
0
 
LVL 24

Expert Comment

by:Steve
ID: 38757946
Hi there CC, I have taken the time to fully test the macro and all should run fine now see below:

Public Sub Update_MA_Risk()

Dim strPath As String: strPath = "C:\Users\Centa\Dropbox\Centa\Centa FXDP\FXDP daily reports\Fixings\"

Dim DestinationFile As String:
DestinationFile = "C:\Users\Centa\Dropbox\Centa\Centa FXDP\Trader Journals\TraderPositionSheet.xlsm"

Dim objFS As Object, objFolder As Object
Dim objFiles As Object, objF1 As Object
Dim strFileName As String, lngFileNumb As Long, IsFileFound As Boolean
Dim FileLen As Integer, Sourcewb As Workbook, DestWb As Workbook
IsFileFound = False

Application.ScreenUpdating = False

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFiles = objFolder.Files

For Each objF1 In objFiles
    If Right(objF1.Name, 3) = "xls" Then
        If IsNumeric(Left(objF1.Name, 8)) Then
            If lngFileNumb < CLng(Left(objF1.Name, 8)) Then
                lngFileNumb = CLng(Left(objF1.Name, 8))
                strFileName = objF1.Name
                IsFileFound = True
            End If
        End If
    End If
Next

Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing

If IsFileFound Then

    Set Sourcewb = Workbooks.Open(strPath & strFileName, , True)
    Set DestWb = Workbooks.Open(DestinationFile, , False)
    
    Sourcewb.Sheets("MA Risk").Range("A1:R80").Copy DestWb.Sheets("MA Risk").Range("A1:R80")
    
    Sourcewb.Close
    Set Sourcewb = Nothing
    
    DestWb.Close (True)
    Set DestWb = Nothing

End If
Application.ScreenUpdating = True

End Sub

Open in new window


Sorry for the problems, this should be fine now.
With-message.txt
0
 

Author Comment

by:CC10
ID: 38759721
Hello Barman,

this works perfectly! Thank you.

Now, my last question on this subject, I promise.

Can you adjust the macro so that DestDb is already open. This is because I have macros in the workbook that are set off on opening as well as a DDE link.

So, the DestinationFile = "C:\Users\Centa\Dropbox\Centa\Centa FXDP\Trader Journals\TraderPositionSheet.xlsm" would be already open before the macro is run.

Then I can fix a timer to the macro and run it at a certain time in the day.

Sorry, I should have mentioned this before but I didn't think.

CC
0
 
LVL 24

Expert Comment

by:Steve
ID: 38759776
OK, this should do the job:

Public Sub Update_MA_Risk()

Dim strPath As String: strPath = "C:\Users\Centa\Dropbox\Centa\Centa FXDP\FXDP daily reports\Fixings\"

Dim DestinationFile As String:
DestinationFile = "C:\Users\Centa\Dropbox\Centa\Centa FXDP\Trader Journals\TraderPositionSheet.xlsm"

Dim objFS As Object, objFolder As Object
Dim objFiles As Object, objF1 As Object
Dim strFileName As String, lngFileNumb As Long, IsFileFound As Boolean
Dim FileLen As Integer, Sourcewb As Workbook, DestWb As Workbook
IsFileFound = False

Application.ScreenUpdating = False

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFiles = objFolder.Files

For Each objF1 In objFiles
    If Right(objF1.Name, 3) = "xls" Then
        If IsNumeric(Left(objF1.Name, 8)) Then
            If lngFileNumb < CLng(Left(objF1.Name, 8)) Then
                lngFileNumb = CLng(Left(objF1.Name, 8))
                strFileName = objF1.Name
                IsFileFound = True
            End If
        End If
    End If
Next

Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing

If IsFileFound Then

    Set Sourcewb = Workbooks.Open(strPath & strFileName, , True)

    Sourcewb.Sheets("MA Risk").Range("A1:R80").Copy Workbooks(DestinationFile).Sheets("MA Risk").Range("A1:R80")
    
    Sourcewb.Close
    Set Sourcewb = Nothing
    
    Workbooks(DestinationFile).Save (True)

End If
Application.ScreenUpdating = True

End Sub

Open in new window


Again this is not tested (am at an alternate PC again) but should work.
If you have issues let me know.
0
 

Author Comment

by:CC10
ID: 38760951
get an error :

wrong number of arguments or invalid property assignment

At line:
Workbooks(DestinationFile).Save (True)
0
 
LVL 24

Expert Comment

by:Steve
ID: 38761035
try just 

Workbooks(DestinationFile).Save

Open in new window


Without the true

I am guessing that you want the change saved :)
0
 

Author Comment

by:CC10
ID: 38761086
now get the error at:
Sourcewb.Sheets("MA Risk").Range("A1:R80").Copy Workbooks(DestinationFile).Sheets("MA Risk").Range("A1:R80")
   
RunTime error 9.  Subscript out of range

here is the code:

Public Sub Update_MA_Risk()

Dim strPath As String: strPath = "C:\Users\Centa\Dropbox\Centa\Centa FXDP\FXDP daily reports\Fixings\"

Dim DestinationFile As String:
DestinationFile = "C:\Users\Centa\Dropbox\Centa\Centa FXDP\Trader Journals\TraderPositionSheet.xlsm"

Dim objFS As Object, objFolder As Object
Dim objFiles As Object, objF1 As Object
Dim strFileName As String, lngFileNumb As Long, IsFileFound As Boolean
Dim FileLen As Integer, Sourcewb As Workbook, DestWb As Workbook
IsFileFound = False

Application.ScreenUpdating = False

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFiles = objFolder.Files

For Each objF1 In objFiles
    If Right(objF1.Name, 3) = "xls" Then
        If IsNumeric(Left(objF1.Name, 8)) Then
            If lngFileNumb < CLng(Left(objF1.Name, 8)) Then
                lngFileNumb = CLng(Left(objF1.Name, 8))
                strFileName = objF1.Name
                IsFileFound = True
            End If
        End If
    End If
Next

Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing

If IsFileFound Then

    Set Sourcewb = Workbooks.Open(strPath & strFileName, , True)

    Sourcewb.Sheets("MA Risk").Range("A1:R80").Copy Workbooks(DestinationFile).Sheets("MA Risk").Range("A1:R80")
   
    Sourcewb.Close
    Set Sourcewb = Nothing
   
    Workbooks(DestinationFile).Save

End If
Application.ScreenUpdating = True

End Sub
0
 
LVL 24

Accepted Solution

by:
Steve earned 1600 total points
ID: 38761997
change the copy line to:
Sourcewb.Sheets("MA Risk").Range("A1:R80").Copy Workbooks("TraderPositionSheet.xlsm").Sheets("MA Risk").Range("A1:R80")

Open in new window


and change the save line to :
Workbooks("TraderPositionSheet.xlsm").Save

Open in new window


Using the full file path is not correct.
0
 

Author Closing Comment

by:CC10
ID: 38762104
BINGO.
I tried to increase the points to 500 but it seems that I cannot. I will try with my next question which will come up soon.
This really helps, so thanks again.
0
 
LVL 24

Expert Comment

by:Steve
ID: 38762272
Points and truly secondary, so no biggie there.
I am happy that we got there in the end.

I may still look at what can be done to improve the code (there is always something).
I think that it may be possible to use the Dir() function rather than FSO.

At least you are back on track.
ATB
Steve.
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

See our Offerings
Question has a verified solution.

If you are experiencing a similar issue, please ask a related question
Freeze Panes feature
Article by: Rob
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
Custom Document Properties in Excel
Article by: Martin
This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
Building Probability Models in Excel Part 6: Investment Modeling Using a Log-Normal Distritribution
Video by: Toby
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
Building Probability Models in Excel Part 7: Modeling a Correlated Two-Fund Investment
Video by: Toby
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
Advertise Here

650 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Advertise Here