asked on

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

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

Steve

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

ASKER

OK Thanks. All the best for 2013.

Steve

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

CC10

ASKER

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

Steve

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.

Steve

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

ASKER

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

ASKER

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

Steve

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

ASKER

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.

Steve

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

ASKER

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

ASKER

Steve

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.

Steve

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

ASKER

I get an error at:
Set Sourcewb = Workbooks.Open(strPath & objF1.Name, , True)

Steve

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

ASKER

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

Steve

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

ASKER

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

Steve

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

ASKER

get an error :

wrong number of arguments or invalid property assignment

At line:
Workbooks(DestinationFile).Save (True)

Steve

try just

Workbooks(DestinationFile).Save

Open in new window

Without the true

I am guessing that you want the change saved :)

CC10

ASKER

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

ASKER CERTIFIED SOLUTION

Steve

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

CC10

ASKER

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.

Steve

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.