Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.
COURSE of the MONTH
15 days, 4 hours left to enrollBecome a Premium Member and unlock a new, free course in leading technologies each month.
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
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
Set objFS = CreateObject("Scripting.Fi
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,
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
'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
' 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).C
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.Appl
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
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
Set objFS = CreateObject("Scripting.Fi
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,
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
'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
' 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).C
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.Appl
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
[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
14-
13
27 Comments
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 :)
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 :)
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:
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
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
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
1) if you wish to move the macro file but point to another folder change the following line (line 3 of the code):
2) the output file is determined by the following line:
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.
Dim strPath As String: strPath = ThisWorkbook.Path
Dim strPath As String: strPath = "C:\Users\Steve\Desktop"
2) the output file is determined by the following line:
Call CopySheetToNewWorkbook(strPath & "\" & strFileName, "A",strPath & "\" & "newFileName.xls")
Call CopySheetToNewWorkbook(strPath & "\" & strFileName, "A","\\FolderY\newFileName.xls")
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.
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...
Let me know if you need more tweaks.
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
Let me know if you need more tweaks.
Am a bit confused with changing the names:
1. the workbook with the macro should be in:
C:\Users\Centa\Dropbox\Cen
2. The Folder with all the data files is:
C:\Users\Centa\Dropbox\Cen
3. The target workbook is:
C:\Users\Centa\Dropbox\Cen
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
1. the workbook with the macro should be in:
C:\Users\Centa\Dropbox\Cen
2. The Folder with all the data files is:
C:\Users\Centa\Dropbox\Cen
3. The target workbook is:
C:\Users\Centa\Dropbox\Cen
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
I am getting there but there is an error at the final line:
Sourcewb.Sheets(shtName).C
Public Sub MailLatestSheet4()
Dim strPath As String: strPath = "C:\Users\Centa\Dropbox\Ce
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
Set objFS = CreateObject("Scripting.Fi
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,
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 CopySheetToExistingWorkboo
Call CopySheetToExistingWorkboo
Application.ScreenUpdating
'MsgBox "Mail Sent", vbCritical, "Macro Complete"
End Sub
Sub CopySheetToExistingWorkboo
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
Set Destwb = Workbooks.Open(txtDestinat
Sourcewb.Sheets(shtName).C
With Destwb
.Save
.Close
End With
End Sub
Sourcewb.Sheets(shtName).C
Public Sub MailLatestSheet4()
Dim strPath As String: strPath = "C:\Users\Centa\Dropbox\Ce
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
Set objFS = CreateObject("Scripting.Fi
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,
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 CopySheetToExistingWorkboo
Call CopySheetToExistingWorkboo
Application.ScreenUpdating
'MsgBox "Mail Sent", vbCritical, "Macro Complete"
End Sub
Sub CopySheetToExistingWorkboo
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
Set Destwb = Workbooks.Open(txtDestinat
Sourcewb.Sheets(shtName).C
With Destwb
.Save
.Close
End With
End Sub
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)
So if you leave that as 1 you should be OK. (or change it to the name of a sheet in the destination workbook)
I am not getting anywhere. I changed the code as follows so that the strPath and newFileName reflected the real names.
'Call CopySheetToExistingWorkboo
Call CopySheetToExistingWorkboo
But I still get an error in the line:
Sourcewb.Sheets(shtName).C
here the worksheet MA Risk is before the worksheet C1 in the workbook TraderPosition Sheet.
'Call CopySheetToExistingWorkboo
Call CopySheetToExistingWorkboo
But I still get an error in the line:
Sourcewb.Sheets(shtName).C
here the worksheet MA Risk is before the worksheet C1 in the workbook TraderPosition Sheet.
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?
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?
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\Cen
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\Cen
4. selects sheet "MA Risk"
5. pastes values and formats
I will increase the points to 500
The macro
1.finds the latest workbook in C:\Users\Centa\Dropbox\Cen
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\Cen
4. selects sheet "MA Risk"
5. pastes values and formats
I will increase the points to 500
You should be able to just change the one line for the copy:
to
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.
to
Sourcewb.Sheets(shtName).range("A1:R80").Copy Workbooks(txtDestinationwb).Sheets(shtName).range("A1:R80")
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.
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
Lol, my bad, is because I set objF1 to nothing furthur up, oops:
Try
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 :)
Try
Set Sourcewb = Workbooks.Open(strPath & objF1.Name, , True)
Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing
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 :)
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\Ce
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
Set objFS = CreateObject("Scripting.Fi
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,
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\C
Sourcewb.Sheets("MA Risk").Range("A1:R80").Cop
Application.ScreenUpdating
End Sub
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\Ce
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
Set objFS = CreateObject("Scripting.Fi
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,
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\C
Sourcewb.Sheets("MA Risk").Range("A1:R80").Cop
Application.ScreenUpdating
End Sub
Hi there CC, I have taken the time to fully test the macro and all should run fine now see below:
Sorry for the problems, this should be fine now.
With-message.txt
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
Sorry for the problems, this should be fine now.
With-message.txt
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\Ce
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
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\Ce
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
OK, this should do the job:
Again this is not tested (am at an alternate PC again) but should work.
If you have issues let me know.
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
Again this is not tested (am at an alternate PC again) but should work.
If you have issues let me know.
get an error :
wrong number of arguments or invalid property assignment
At line:
Workbooks(DestinationFile)
wrong number of arguments or invalid property assignment
At line:
Workbooks(DestinationFile)
try just
Without the true
I am guessing that you want the change saved :)
Workbooks(DestinationFile).Save
Without the true
I am guessing that you want the change saved :)
now get the error at:
Sourcewb.Sheets("MA Risk").Range("A1:R80").Cop
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\Ce
Dim DestinationFile As String:
DestinationFile = "C:\Users\Centa\Dropbox\Ce
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
Set objFS = CreateObject("Scripting.Fi
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,
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").Cop
Sourcewb.Close
Set Sourcewb = Nothing
Workbooks(DestinationFile)
End If
Application.ScreenUpdating
End Sub
Sourcewb.Sheets("MA Risk").Range("A1:R80").Cop
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\Ce
Dim DestinationFile As String:
DestinationFile = "C:\Users\Centa\Dropbox\Ce
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
Set objFS = CreateObject("Scripting.Fi
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,
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").Cop
Sourcewb.Close
Set Sourcewb = Nothing
Workbooks(DestinationFile)
End If
Application.ScreenUpdating
End Sub
change the copy line to:
and change the save line to :
Using the full file path is not correct.
Sourcewb.Sheets("MA Risk").Range("A1:R80").Copy Workbooks("TraderPositionSheet.xlsm").Sheets("MA Risk").Range("A1:R80")
and change the save line to :
Workbooks("TraderPositionSheet.xlsm").Save
Using the full file path is not correct.
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.
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.
Featured Post
An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.
One of a set of tools we're offering as a way of saying thank you for being a part of the community.
Question has a verified solution.
If you are experiencing a similar issue, please ask a related question
Introduction
This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results.
Paraphrasing Richard Shockley, author of my favourite finance reference tex…
If you need to forecast numbers -- typically for finance -- the Windows and Mac versions of Excel 2016 have a basket of tools to get the job done.
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data.
Rather than update each graph to point to a different set within a static set of data, t…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
Suggested Courses
Course of the Month15 days, 4 hours left to enroll
770 members asked questions and received personalized solutions in the past 7 days.
Join the community of 500,000 technology professionals and ask your questions.