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
Dim strPath As String: strPath = ThisWorkbook.Path
to the location of the files (for example):Dim strPath As String: strPath = "C:\Users\Steve\Desktop"
Call CopySheetToNewWorkbook(strPath & "\" & strFileName, "A",strPath & "\" & "newFileName.xls")
change this to change the output file (for example):Call CopySheetToNewWorkbook(strPath & "\" & strFileName, "A","\\FolderY\newFileName.xls")
This will however overwrite the whole file.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
Sourcewb.Sheets(shtName).range("A1:R80").Copy Workbooks(txtDestinationwb).Sheets(shtName).range("A1:R80")
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
Set Sourcewb = Workbooks.Open(strPath & objF1.Name, , True)
Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing
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
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
Workbooks(DestinationFile).Save
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 :)