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

CC10
CC10 used Ask the Experts™
on
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
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
View Solution Only
SteveCost Accountant
Top Expert 2012

Commented:
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 :)
CC10

Author

Commented:
OK Thanks.  All the best for 2013.
SteveCost Accountant
Top Expert 2012

Commented:
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

Become a Certified Penetration Testing Engineer

This CPTE Certified Penetration Testing Engineer course covers everything you need to know about becoming a Certified Penetration Testing Engineer. Career Path: Professional roles include Ethical Hackers, Security Consultants, System Administrators, and Chief Security Officers.

Learn More!
CC10

Author

Commented:
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
SteveCost Accountant
Top Expert 2012

Commented:
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.
SteveCost Accountant
Top Expert 2012

Commented:
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.
CC10

Author

Commented:
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
CC10

Author

Commented:
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
SteveCost Accountant
Top Expert 2012

Commented:
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)
CC10

Author

Commented:
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.
SteveCost Accountant
Top Expert 2012

Commented:
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?
CC10

Author

Commented:
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
CC10

Author

Commented:
x
SteveCost Accountant
Top Expert 2012

Commented:
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.
SteveCost Accountant
Top Expert 2012

Commented:
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

CC10

Author

Commented:
I get an error at:
Set Sourcewb = Workbooks.Open(strPath & objF1.Name, , True)
SteveCost Accountant
Top Expert 2012

Commented:
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 :)
CC10

Author

Commented:
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
SteveCost Accountant
Top Expert 2012

Commented:
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
CC10

Author

Commented:
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
SteveCost Accountant
Top Expert 2012

Commented:
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.
CC10

Author

Commented:
get an error :

wrong number of arguments or invalid property assignment

At line:
Workbooks(DestinationFile).Save (True)
SteveCost Accountant
Top Expert 2012

Commented:
try just 

Workbooks(DestinationFile).Save

Open in new window


Without the true

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

Author

Commented:
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
Cost Accountant
Top Expert 2012
Commented:
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.
CC10

Author

Commented:
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.
SteveCost Accountant
Top Expert 2012

Commented:
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.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial