I am trying to Open, excel sheet from a shared drive, copy the first 8 tabs, with the copied sheets, open a new workbook and special paste with all the formulas, then Open a separate folder from the same shared drive, copy all the tabs and move them to the new workkbook we just copied the 8 tabs , save as NSM07272015-NA.xls, then email the same file as an attachment using VBA. Below is my cose, i compiled, but I still get errors. Please assist. Thank you all in advance.
Sub Macro1()
'
' Macro1 Macro
'
'
Workbooks.Open Filename:= _
"E:\\Test\Sheets072415.xlsx"
Sub NewWBandPasteSpecialALLSheets()
Dim wb As Workbook
Dim wbNew As Workbook
Dim sh As Worksheet
Dim shNew As Worksheet
Set wb = ThisWorkbook
Workbooks.Add ' Open a new workbook
Set wbNew = ActiveWorkbook
On Error Resume Next
For Each sh In wb.Worksheets
sh.Range("Price ").Copy
sh.Range("MSR ").Copy
sh.Range("Stdrd ").Copy
sh.Range("Plus ").Copy
sh.Range("Relief ").Copy
sh.Range("HA ").Copy
sh.Range("VA ").Copy
sh.Range("Conforming ").Copy
'add new sheet into new workbook with the same name
With wbNew.Worksheets
Set shNew = Nothing
Set shNew = .Item("sh.Price ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.Price "
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item(sh.Price)
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.MSR "
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.MSR ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.AgencyStdrd NCA"
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.Stdrd ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.Plus "
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.Plus ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.Relief "
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.Relief ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.HA "
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.HA ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.VA"
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.VA")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.Conforming"
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.Conforming ")
End If
End With
With shNew.Range("A1")
.PasteSpecial (xlPasteColumnWidths)
.PasteSpecial (xlFormats)
.PasteSpecial (xlValues)
End With
Next
Workbooks.Open Filename:="E:\Sheets\Term_Adjusters.xlsx"
'Copy worksheet
Application.ScreenUpdating = False
Dim wb As Workbook
Dim NewShtName As String
NewShtName = "Term_Adjusters.xlsx"
Sheets(" Amt Adj", "LTV Adj", " Adj", " Score Adj", _
"Purp Adj", "TX Adj", "Occupancy Adj", "Type Adj", "TermAdj").Copy
Set wb = ActiveWorkbook
wb.Sheets(" Amt Adj", "LTV Adj", " Adj", " Score Adj", _
"Purp Adj", "TX Adj", "Occupancy Adj", "Type Adj", "TermAdj").Name = ActiveWorkbook
.Move _
Before:=Workbooks("Book1").Sheets(12)
'Prompt for SaveAs name, Want to save it like nsm07272015_RRR
DstFile = Application.GetSaveAsFilename _
(InitialFileName:="NSM" & "CurrentDate" & "NA" & .xls, _
Title:="Save As")
If DstFile = "False" Then
MsgBox "File not Saved, Actions Cancelled."
Exit Sub
Else
wb.SaveAs DstFile 'Save file
wb.Close 'Close file
End If
Workbooks("Job Log.xls").Activate
MsgBox ("File Saved")
Application.ScreenUpdating = True
End If
Dim LastRow As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
ChDir "E:\MMargin\RateSheets\Test"
Set obj = Application.Dialogs(xlDialogSendMail).Show
Windows("Sheets07272015.xlsx").Activate
With objMail
.To = "see.rrocls@natmail.com"
.Subject = "Daily Reports"
.Body = "Attached is a Daily Report"
.Attachments.Add "E:\Test\Sheets07272015.xlsx"
.Send
End Sub
Sub Macro1()
'
' Macro1 Macro
'
'
Workbooks.Open Filename:= _
"E:\\Test\Sheets072415.xlsx"
Sub NewWBandPasteSpecialALLSheets()
Dim wb As Workbook
Dim wbNew As Workbook
Dim sh As Worksheet
Dim shNew As Worksheet
Set wb = ThisWorkbook
Workbooks.Add ' Open a new workbook
Set wbNew = ActiveWorkbook
On Error Resume Next
For Each sh In wb.Worksheets
sh.Range("Price ").Copy
sh.Range("MSR ").Copy
sh.Range("Stdrd ").Copy
sh.Range("Plus ").Copy
sh.Range("Relief ").Copy
sh.Range("HA ").Copy
sh.Range("VA ").Copy
sh.Range("Conforming ").Copy
'add new sheet into new workbook with the same name
With wbNew.Worksheets
Set shNew = Nothing
Set shNew = .Item("sh.Price ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.Price "
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item(sh.Price)
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.MSR "
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.MSR ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.AgencyStdrd NCA"
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.Stdrd ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.Plus "
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.Plus ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.Relief "
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.Relief ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.HA "
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.HA ")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.VA"
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.VA")
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = "sh.Conforming"
Set shNew = .Item(.Count)
Set shNew = Nothing
Set shNew = .Item("sh.Conforming ")
End If
End With
With shNew.Range("A1")
.PasteSpecial (xlPasteColumnWidths)
.PasteSpecial (xlFormats)
.PasteSpecial (xlValues)
End With
Next
Workbooks.Open Filename:="E:\Sheets\Term_Adjusters.xlsx"
'Copy worksheet
Application.ScreenUpdating = False
Dim wb As Workbook
Dim NewShtName As String
NewShtName = "Term_Adjusters.xlsx"
Sheets(" Amt Adj", "LTV Adj", " Adj", " Score Adj", _
"Purp Adj", "TX Adj", "Occupancy Adj", "Type Adj", "TermAdj").Copy
Set wb = ActiveWorkbook
wb.Sheets(" Amt Adj", "LTV Adj", " Adj", " Score Adj", _
"Purp Adj", "TX Adj", "Occupancy Adj", "Type Adj", "TermAdj").Name = ActiveWorkbook
.Move _
Before:=Workbooks("Book1").Sheets(12)
'Prompt for SaveAs name, Want to save it like nsm07272015_RRR
DstFile = Application.GetSaveAsFilename _
(InitialFileName:="NSM" & "CurrentDate" & "NA" & .xls, _
Title:="Save As")
If DstFile = "False" Then
MsgBox "File not Saved, Actions Cancelled."
Exit Sub
Else
wb.SaveAs DstFile 'Save file
wb.Close 'Close file
End If
Workbooks("Job Log.xls").Activate
MsgBox ("File Saved")
Application.ScreenUpdating = True
End If
Dim LastRow As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
ChDir "E:\MMargin\RateSheets\Test"
Set obj = Application.Dialogs(xlDialogSendMail).Show
Windows("Sheets07272015.xlsx").Activate
With objMail
.To = "see.rrocls@natmail.com"
.Subject = "Daily Reports"
.Body = "Attached is a Daily Report"
.Attachments.Add "E:\Test\Sheets07272015.xlsx"
.Send
End Sub
