Hello and thank you for contacting JustAnswer, a paid expert support site. My name is XXXXX XXXXX X'X be glad to assist you with your issue.
So, in F2, you have a path (C:\...\...\) to a file, correct?
That is correct.
Ok, just a second. This should be pretty easy.
Try: .Attachments.Add = Sheets("Sheet1").Range("F2").Text
Replacing the "Sheet1" with your sheet name
It did not work.
Ok, we may need an actual file object. Just a sec.
The macro splits sheet1 into seperate sheets based on the user emails address then emails the worksheet to user.
Ah ok, so are you taking into account the new sheet, then?
Just for giggles, you might want to do an MsgBox for that value (Sheets("Sheet1").Range("F2").Text) and make sure it is the correct path.
Not sure what you mean on that one
To make sure you are getting the right path.
You can do MsgBox Sheets("Sheet1").Range("F2").Text
and it will popup an alert box with that value. If you have the right cell/sheet, it should have the path in it.
If you think it might help, you can send me the sheet so I can see exactly what you are trying to do.
Here you go
did you receive the file?
Where is the macro? In Outlook?
I don't see a Macro on this document
Sub Split_Worksheets()'Note: This macro use the function LastRow Dim My_Range As Range Dim FieldNum As Long Dim CalcMode As Long Dim ViewMode As Long Dim ws2 As Worksheet Dim Lrow As Long Dim cell As Range Dim CCount As Long Dim WSNew As Worksheet Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range 'and the header of the first column, D is the last column in the filter range. 'You can also add the sheet name to the code like this : 'Worksheets("Sheet1").Range("A1:K" & LastRow(Worksheets("Sheet1"))) 'No need that the sheet is active then when you run the macro when you use this. Set My_Range = Range("A1:F5") ' & LastRow(ActiveSheet)) My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _ My_Range.Parent.ProtectContents = True Then MsgBox "Sorry, not working when the workbook or worksheet is protected", _ vbOKOnly, "Copy to new worksheet" Exit Sub End If
'This example filters on the tenth column in the range(change the field if needed) 'In this case the range starts in A so Field:=1 is column A, 2 = column B, ...... FieldNum = 5 ' I changed this to 5 for column E
'Turn off AutoFilter My_Range.Parent.AutoFilterMode = False
'Change ScreenUpdating, Calculation, EnableEvents, .... With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView ActiveSheet.DisplayPageBreaks = False
'Add a worksheet to copy the a unique list and add the CriteriaRange Set ws2 = Worksheets.Add
With ws2 'first we copy the Unique data from the filter field to ws2 My_Range.Columns(FieldNum).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("A1"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet Lrow = .Cells(Rows.Count, "A").End(xlUp).Row For Each cell In .Range("A2:A" & Lrow)
'Filter the range My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _ Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas) CCount = 0 On Error Resume Next CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _ .Areas(1).Cells.Count On Error GoTo 0 If CCount = 0 Then MsgBox "There are more than 8192 areas for the value : " & cell.Value _ & vbNewLine & "It is not possible to copy the visible data." _ & vbNewLine & "Tip: Sort your data before you use this macro.", _ vbOKOnly, "Split in worksheets" Else 'Add a new worksheet Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count)) On Error Resume Next WSNew.Name = cell.Value If Err.Number > 0 Then ErrNum = ErrNum + 1 WSNew.Name = "Error_" & Format(ErrNum, "0000") Err.Clear End If On Error GoTo 0
'Copy the visible data to the new worksheet My_Range.SpecialCells(xlCellTypeVisible).Copy With WSNew.Range("A1") ' Paste:=8 will copy the columnwidth in Excel 2000 and higher ' Remove this line if you use Excel 97 .PasteSpecial Paste:=8 .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False .Select End With End If
'Show all data in the range My_Range.AutoFilter Field:=FieldNum
'Delete the ws2 sheet On Error Resume Next Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True On Error GoTo 0
If ErrNum > 0 Then MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _ & vbNewLine & "There are characters in the name that are not allowed" _ & vbNewLine & "in a sheet name or the worksheet already exist." End If
'Restore ScreenUpdating, Calculation, EnableEvents, .... My_Range.Parent.Select ActiveWindow.View = ViewMode With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With
MsgBox ("Copy Complete - - Remember to save your work.")
Sub Email_MAH()'Working in 2000-2010 Dim Source As Range Dim Dest As Workbook Dim wb As Workbook Dim TempFilePath As String Dim TempFileName As String Dim FileExtStr As String Dim FileFormatNum As Long Dim OutApp As Object Dim OutMail As Object
For Each sht In ActiveWorkbook.Sheetssht.ActivateSendTo = sht.Range("E2").Value Set Source = Nothing On Error Resume Next Set Source = Range("A1:E2").SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Source Is Nothing Then MsgBox "The source is not a range or the sheet is protected, " & _ "please correct and try again.", vbOKOnly Exit Sub End If With Application .ScreenUpdating = False .EnableEvents = False End With
Set wb = ActiveWorkbook Set Dest = Workbooks.Add(xlWBATWorksheet) Source.Copy With Dest.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial Paste:=xlPasteValues .Cells(1).PasteSpecial Paste:=xlPasteFormats .Cells(1).Select Application.CutCopyMode = False End With TempFilePath = Environ$("temp") & "\" TempFileName = sht.Name & " " _ & Format(Now, "mm-dd-yyyy") If Val(Application.Version) < 12 Then 'You use Excel 2000-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else 'You use Excel 2007-2010 FileExtStr = ".xls": FileFormatNum = 56 End If Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With Dest .SaveAs TempFilePath & TempFileName & FileExtStr, _ FileFormat:=FileFormatNum On Error Resume Next With OutMail .To = SendTo .From = "" .CC = "" .BCC = "" .Subject = "Master Account Holder - ACTION REQUIRED" .Body = "The Southeastern Kidney Council (SKC) distributes the Near Match report based on data reported by the CROWNWeb contractor in charge of batch submission. Errors prohibited the following patient data from your EMR (Electronic Medical Record) system from loading into CROWNWeb. Patient records must match exactly for the following identifiers: HIC, SSN, last name, first name, gender and DOB. The system rejects patient records that do not match the six identifiers. The Near Match Report contains patients with incorrect data. For each patient update your corporate system with the CROWNWeb value for records noted incorrect. Attached are instructions to resolve the error and admit the patient to CROWNWeb." .Attachments.Add = Sheets("Sheet1").Range("F2").Text 'You can add other files also like this .Attachments.Add ("I:\Aim 3 Improve Care to Reduce Cost\Quality Incentive Program (QIP)\MAH Folder\Detailed Facility Instructions.pdf") .Attachments.Add ("I:\Aim 3 Improve Care to Reduce Cost\Quality Incentive Program (QIP)\MAH Folder\Instructions for Setting Up Corporate Account of Your Dialysis Organization.pdf") .Send End With On Error GoTo 0 .Close SaveChanges:=False End With Kill TempFilePath & TempFileName & FileExtStr Set OutMail = Nothing Set OutApp = Nothing With Application .ScreenUpdating = True .EnableEvents = True End With NextEnd Sub
Ah, sorry! .Attachments.Add (Sheets("Sheet1").Range("F2").Text)
not equals... Haha
The file is still not attached. It attached the 2 files with the file path but not this one.
Ok, just before that, put this: MsgBox (Sheets("Sheet1").Range("F2").Text)
Does a box popup with I:\Aim 3 Improve Care to Reduce Cost\Quality Incentive Program (QIP)\MAH Folder\WebAccess\WebAccess_110038.pdf in it?
The box is blank.
Ok, that is why. It isn't getting the path from that field.
Is that macro run from within this excel sheet?
The path in field F2 =
Again, the Sheet1 was split into workbooks based on the email addres. So each worksheet has the correct path in field F2. Some how we need to loop thru the worksheets.
Right, but what I had you do it give a msgbox to make sure that the script can get that value.
Well, the sheet would be named the email address, right?
If so, try this instead: MsgBox (Sheets(SendTo).Range("F2").Text)
The email goes to that email address, correct?
Yes. Change the current message box or add a new one?
No message appears and only the 2 files are attached.
Hrm, that is odd, it should still appear blank if anything.
I ran in 3 times.
Ohh, I see - it's in a For Loop. We need to do this:
Replace the one before with: MsgBox (sht.Range("F2").Value)
Anything this time?
Now, I get a box with the file location.
Replace it with this, then: .Attachments.Add (sht.Range("F2").Value)
Okay, it worked but each record received 2 emails. One email contained the 3 documents an the other only contained 2.
So, the second email didn't attach the file in F2?
Yes the second email did attach the file
It did? Maybe I am not understanding.
Each record received two emails?
I removed the message box and everything is okay now. Thanks!
Ah, ok. Good.
I hope I have been helpful in today's session. It has been a pleasure working with you. Please be sure to rate the service you received today. You may also provide a tip after rating, if you feel I deserve one (thank you in advance!). Should you wish to request me in the future, you can bookmark/favorite my profile page by clicking my name on the left. Have a great rest of your day.