I have two worksheets, one called "In out record_AT" and another called "Site Cable Usage".
I want to create new Site Cable Usage sheet with "In out record_AT" row G number, then attach "In out record_AT" and multiple Site Cable Usage Sheet worksheets in one email but it has the duplicate attachment problem as attached image.
Would anyone can help?
Thank you very much
Sub Create_Site_Cable_Usage_AT()
Set wSheetStart = ThisWorkbook.Sheets("In out record_AT")
Dim LastRow As Long, i As Long
LastRow = wSheetStart.Cells(Rows.Count, "G").End(xlUp).Row
For i = 17 To LastRow
Set copysheet = ThisWorkbook.Sheets("Site Cable Usage")
copysheet.Activate
copysheet.Range("A1:S78").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
ActiveSheet.Name = "Site Cable Usage" & i
Set copysheet2 = ThisWorkbook.Sheets("Site Cable Usage" & i)
copysheet2.Range("B10").Value = wSheetStart.Range("D" & i).Value
Next i
Call Send_email_AT
End Sub
Public Sub Send_email_AT()
Dim FileExtStr, FileExtStr2, FileExtStr3 As String
Dim FileFormatNum, FileFormatNum2, FileFormatNum3 As Long
Dim Sourcewb, Sourcewb2, Sourcewb3 As Workbook
Dim Destwb, Destwb2, Destwb3 As Workbook
Dim TempFilePath, TempFilePath2, TempFilePath3 As String
Dim TempFileName, TempFileName2, TempFileName3 As String
Dim OutApp, OutApp2, OutApp3 As Object
Dim OutMail, OutMail2, OutMail3 As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
ActiveWorkbook.Worksheets("In out record_AT").Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
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
TempFilePath = Environ$("temp") & "\"
TempFileName = "In out record_AT" & " " & Format(Now, "dd-mm-yyyy ")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Destwb.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
Destwb.Close savechanges:=False
Set Destwb3 = ActiveWorkbook
Set wSheetStart = ThisWorkbook.Sheets("In out record_AT")
Dim LastRow As Long, i As Long
LastRow = wSheetStart.Cells(Rows.Count, "G").End(xlUp).Row
For i = 17 To LastRow
With Destwb3
ActiveWorkbook.Worksheets("Site Cable Usage" & i).Copy
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr3 = ".xls": FileFormatNum = -4143
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr3 = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr3 = ".xlsm": FileFormatNum = 52
Else
FileExtStr3 = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr3 = ".xls": FileFormatNum = 56
Case Else: FileExtStr3 = ".xlsb": FileFormatNum = 50
End Select
End If
End With
TempFilePath3 = Environ$("temp") & "\"
TempFileName3 = "Site Cable Usage" & i
Destwb3.SaveAs TempFilePath3 & TempFileName3 & FileExtStr3, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "[email protected]"
.To = "[email protected]"
.CC = "[email protected]"
.BCC = "Tse, Kassie Hoi Yi <[email protected]>; Ng, Lok Yi <[email protected]>"
.Subject = "In Out Record on " & Format(Now, "dd/mm/yyyy ") & "- AT"
'"You may print the In Out Record to collect the cable." & vbNewLine & "Please do not reply to this email."
.htmlbody = _
"<p style='font-family:calibri;font-size:21'>Dear Subcontractor,<br/></p>"
'.Body = "You may print out In Out Record to collect the cable ."
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Attachments.Add Destwb3.FullName
.display
End With
Next i
On Error GoTo 0
Destwb3.Close savechanges:=False
Kill TempFilePath & TempFileName & FileExtStr
Kill TempFilePath3 & TempFileName3 & FileExtStr3
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I have two worksheets, one called "In out record_AT" and another called "Site Cable Usage".
I want to create new Site Cable Usage sheet with "In out record_AT" row G number, then attach "In out record_AT" and multiple Site Cable Usage Sheet worksheets in one email but it has the duplicate attachment problem as attached image.
Would anyone can help?
Thank you very much
Sub Create_Site_Cable_Usage_AT()
Set wSheetStart = ThisWorkbook.Sheets("In out record_AT")
Dim LastRow As Long, i As Long
LastRow = wSheetStart.Cells(Rows.Count, "G").End(xlUp).Row
For i = 17 To LastRow
Set copysheet = ThisWorkbook.Sheets("Site Cable Usage")
copysheet.Activate
copysheet.Range("A1:S78").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
ActiveSheet.Name = "Site Cable Usage" & i
Set copysheet2 = ThisWorkbook.Sheets("Site Cable Usage" & i)
copysheet2.Range("B10").Value = wSheetStart.Range("D" & i).Value
Next i
Call Send_email_AT
End Sub
Public Sub Send_email_AT()
Dim FileExtStr, FileExtStr2, FileExtStr3 As String
Dim FileFormatNum, FileFormatNum2, FileFormatNum3 As Long
Dim Sourcewb, Sourcewb2, Sourcewb3 As Workbook
Dim Destwb, Destwb2, Destwb3 As Workbook
Dim TempFilePath, TempFilePath2, TempFilePath3 As String
Dim TempFileName, TempFileName2, TempFileName3 As String
Dim OutApp, OutApp2, OutApp3 As Object
Dim OutMail, OutMail2, OutMail3 As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
ActiveWorkbook.Worksheets("In out record_AT").Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
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
TempFilePath = Environ$("temp") & "\"
TempFileName = "In out record_AT" & " " & Format(Now, "dd-mm-yyyy ")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Destwb.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
Destwb.Close savechanges:=False
Set Destwb3 = ActiveWorkbook
Set wSheetStart = ThisWorkbook.Sheets("In out record_AT")
Dim LastRow As Long, i As Long
LastRow = wSheetStart.Cells(Rows.Count, "G").End(xlUp).Row
For i = 17 To LastRow
With Destwb3
ActiveWorkbook.Worksheets("Site Cable Usage" & i).Copy
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr3 = ".xls": FileFormatNum = -4143
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr3 = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr3 = ".xlsm": FileFormatNum = 52
Else
FileExtStr3 = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr3 = ".xls": FileFormatNum = 56
Case Else: FileExtStr3 = ".xlsb": FileFormatNum = 50
End Select
End If
End With
TempFilePath3 = Environ$("temp") & "\"
TempFileName3 = "Site Cable Usage" & i
Destwb3.SaveAs TempFilePath3 & TempFileName3 & FileExtStr3, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "[email protected]"
.To = "[email protected]"
.CC = "[email protected]"
.BCC = "Tse, Kassie Hoi Yi <[email protected]>; Ng, Lok Yi <[email protected]>"
.Subject = "In Out Record on " & Format(Now, "dd/mm/yyyy ") & "- AT"
'"You may print the In Out Record to collect the cable." & vbNewLine & "Please do not reply to this email."
.htmlbody = _
"<p style='font-family:calibri;font-size:21'>Dear Subcontractor,<br/></p>"
'.Body = "You may print out In Out Record to collect the cable ."
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Attachments.Add Destwb3.FullName
.display
End With
Next i
On Error GoTo 0
Destwb3.Close savechanges:=False
Kill TempFilePath & TempFileName & FileExtStr
Kill TempFilePath3 & TempFileName3 & FileExtStr3
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
1 Answer
Reset to default 1Build a collection of files to attach.
Option Explicit
Sub Create_Site_Cable_Usage_AT()
Dim wb As Workbook, ws As Worksheet, rngCopy As Range
Dim LastRow As Long, r As Long, c As Long
Set wb = ThisWorkbook
Set rngCopy = wb.Sheets("Site Cable Usage").Range("A1:S78")
With wb.Sheets("In out record_AT")
LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
For r = 17 To LastRow
Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
rngCopy.Copy ws.Range("A1")
ws.Cells(10, "B") = .Cells(r, "D")
ws.Name = "Site Cable Usage" & r
' adjust column widths
For c = 1 To rngCopy.Columns.Count
ws.Columns(c).ColumnWidth = rngCopy.Columns(c).ColumnWidth
Next
Next
End With
Call Send_email_AT
End Sub
Public Sub Send_email_AT()
Dim wb As Workbook, wsIO As Worksheet, ws As Worksheet
Dim LastRow As Long, r As Long, s As String
Dim colAttach As Collection, i As Long, f As String
Set colAttach = New Collection
Set wb = ThisWorkbook
Application.ScreenUpdating = False
' create temp copies of each sheet
' In out record_AT Sheet
Set wsIO = wb.Sheets("In out record_AT")
f = SaveToTemp(wsIO, wsIO.Name & Format(Now, "dd-mm-yyyy "))
colAttach.Add f, CStr(0)
' Site Cable Usage Sheets
With wsIO
LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
For r = 17 To LastRow
Set ws = wb.Sheets("Site Cable Usage" & r)
f = SaveToTemp(ws, ws.Name)
colAttach.Add f, CStr(r)
Next
End With
Application.ScreenUpdating = True
' create email
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "[email protected]"
.to = "[email protected]"
.CC = "[email protected]"
.BCC = "Tse, Kassie Hoi Yi <[email protected]>; Ng, Lok Yi <[email protected]>"
.Subject = "In Out Record on " & Format(Now, "dd/mm/yyyy ") & "- AT"
' "You may print the In Out Record to collect the cable." & vbNewLine & "Please do not reply to this email."
.htmlbody = _
"<p style='font-family:calibri;font-size:21'>Dear Subcontractor,<br/></p>"
'.Body = "You may print out In Out Record to collect the cable ."
For i = 1 To colAttach.Count
.Attachments.Add colAttach(i)
Debug.Print colAttach(i)
Next
.display
End With
' delete temp files
If MsgBox("Delete temp files ? ", vbYesNo) = vbYes Then
For i = 1 To colAttach.Count
Debug.Print "Deleted " & colAttach(i)
Kill colAttach(i)
Next
End If
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function SaveToTemp(ws As Worksheet, s As String)
Dim FileExtStr As String, TempFilePath As String
Dim FileFormatNum As Long, c As Long
TempFilePath = Environ$("temp") & "\"
' copy sheet to new workbook
ws.Copy
With ActiveWorkbook
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case .FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If ActiveWorkbook.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
' save workbook to temp
s = TempFilePath & s & FileExtStr
.SaveAs s, FileFormatNum
.Close
End With
' return full file path and name
SaveToTemp = s
End Function
发布者：admin，转转请注明出处：http://www.yc00.com/questions/1744870368a4598224.html
.Attachments.Add TempFilePath & TempFileName & FileExtStrtoIf i = 17 Then .Attachments.Add TempFilePath & TempFileName & FileExtStr– CDP1802 Commented Mar 9 at 22:39