TheRealLethality
New Member
- Joined
- Jul 15, 2014
- Messages
- 1
Hoping someone can give me a hand with this macro, I am trying to make for my work so we can track ongoing jobs and auto email it to the next person in the follow of operations. I have it doing just about everything I want it to do, except when it copies from the original .xlsm workbook and emails itself its changed from .xlsm to .xlsx, and when you click he form button in the new .xlsx it tries to use the original workbook's macros. I just want the below macros to copy the data from the work request form worksheet and log it in the work request form - history worksheet, then email all of it, including the macros to the next person. Thanks in advance!
Code:
Sub Mail_Sheets_FieldSup()
If Worksheets("Work Request Form").Range("B2").Value = "" Then
MsgBox "The Job Type is required, aborting operation..."
Exit Sub
End If
If Worksheets("Work Request Form").Range("B3").Value = "" Then
MsgBox "The Well Name is required, aborting operation..."
Exit Sub
End If
If Worksheets("Work Request Form").Range("B4").Value = "" Then
MsgBox "The Client is required, aborting operation..."
Exit Sub
End If
If Worksheets("Work Request Form").Range("B10").Value = "" Then
MsgBox "The Assigned Supervisor is required, aborting operation..."
Exit Sub
End If
If Worksheets("Work Request Form").Range("B11").Value = "" Then
MsgBox "The Assigned Supervisor's Email is required, aborting operation..."
Exit Sub
End If
If Worksheets("Work Request Form").Range("B12").Value = "" Then
MsgBox "The Job Start Date is required, aborting operation..."
Exit Sub
End If
Sheets("Work Request Form").Activate
Range("b25").Select
ActiveCell.FormulaR1C1 = "Field Supervisor"
Sheets("Work Request Form - HISTORY").Unprotect Password:="dfsdsd"
Select Case Sheets("Work Request Form - HISTORY").Range("b2") = ""
Case True 'paste in col A if A1 is empty
Sheets("Work Request Form").Range("b2:b25").Copy Sheets("Work Request Form - HISTORY").Range("b2")
Case False ' paste to next col
Sheets("Work Request Form").Range("b2:b25").Copy Sheets("Work Request Form - HISTORY").Range("XFD2").End(xlToLeft).Offset(0, 1)
End Select
Sheets("Work Request Form - HISTORY").Activate
Sheets("Work Request Form - HISTORY").Rows("2:25").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
Sheets("Work Request Form - HISTORY").Columns("B:XFD").Select
Selection.ColumnWidth = 32
Selection.Locked = True
Selection.FormulaHidden = False
Rows("2:25").EntireRow.AutoFit
Sheets("Work Request Form - HISTORY").Protect Password:="dfsdsd", DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("Work Request Form - HISTORY").EnableSelection = xlNoRestrictions
Cells(1, 1).Select
'Working in Excel 2000-2013
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
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
Dim rng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheets to a new workbook
'We add a temporary Window to avoid the Copy problem
'if there is a List or Table in one of the sheets and
'if the sheets are grouped
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("Work Request Form", "Work Request Form - HISTORY", "How to Dispatch Jobs in Spira", "Workflow - Process Map")).Copy
End With
'Close temporary Window
TempWindow.Close
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
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 With
' 'Change all cells in the worksheets to values if you want
' For Each sh In Destwb.Worksheets
' sh.Select
' With sh.UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
' Destwb.Worksheets(1).Select
' Next sh
For Each sh In Destwb.Worksheets
sh.Select
With sh.Rows("26:35").Select
sh.Unprotect Password:="dfsdsd"
Selection.EntireRow.Hidden = False
ActiveSheet.Buttons.Delete
With ActiveSheet
With .Range("d26:f26")
ActiveSheet.Buttons.Add(.Left, .Top, .Width, .Height).Select
End With
End With
Selection.Name = "Send Job to Supervisor"
Selection.OnAction = "Mail_Sheets_Supervisor"
ActiveSheet.Shapes("Send Job to Supervisor").Select
With Selection
.Characters.Text = "Send Job to Supervisor"
With .Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
With Selection
.Locked = False
.LockedText = True
End With
With Selection
.Placement = xlMove
.PrintObject = False
End With
End With
With ActiveSheet
With .Range("d30:f30")
ActiveSheet.Buttons.Add(.Left, .Top, .Width, .Height).Select
End With
End With
Selection.Name = "Submit to Accounting"
Selection.OnAction = "Mail_Sheets_Accounting"
ActiveSheet.Shapes("Submit to Accounting").Select
With Selection
.Characters.Text = "Submit to Accounting"
With .Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
With Selection
.Locked = False
.LockedText = True
End With
With Selection
.Placement = xlMove
.PrintObject = False
End With
End With
sh.Name = "NEW Job Request by Prod Mngr"
sh.Protect Password:="dfsdsd", DrawingObjects:=True, Contents:=True, Scenarios:=True
sh.EnableSelection = xlNoRestrictions
Range("A26:B26").Select
End With
Exit For
Next sh
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "NEW Job Request" & " " & Format(Now, "dd-mmm-yyyy hh-mm")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "Me@live.com"
.CC = ""
.BCC = ""
.Subject = "*NEW* Job Request Form"
.Body = "Field Supervisor," & vbCrLf & _
" Please use the attached data." & _
vbCrLf & "Regards" & vbCrLf & "Production" & vbCrLf & _
"Please call the office with any questions" & vbCrLf & _
"Main: Numbers"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Sheets("Work Request Form - HISTORY").Activate
Sheets("Work Request Form").Range("b2:b25").ClearContents
ActiveWorkbook.Save
End Sub
