VBA - Taking a Filtered Dataset, Moving it to a New workbook, and Only pasting the Visible Cells

[Michael515]

Hi Y'all,

What I'm trying to do is as follows:

In the CODE sheet I'm looking at Column C to see if the cell value = "Yes", if it does we then filter the DASBOARD sheet based on the corresponding value in column A of the CODE sheet (I loop it so that whenever we look at column C, if "Yes", we filter based on the same row value column A).

Now this is where I'm running into problems:

After filtering the DASHBOARD sheet, I want to take that sheet, and send it as an email attachment. So the next part of my code, which I have used previously for other similar tasks, is pasted to do just that based on the appropriate "i" row ("i" being the variable that we are looping). This is where I encounter a problem: I'm trying to take only the filtered cells and paste them into the new workbook (or temporary workbook if you will) that will be emailed off. However, every time I paste it over into the new workbook, it takes all the data, and not just the filtered (or visible) cells. I tried to tinker around with the paste, and sometimes I get the error that the copied range and paste range don't match in size. I know it has something to do with only copying the visible cells, but my question is where in the "email code" do I distinguish that. My email code is from Ron de Bruin's templates, and I've been trying to tinker within it, but I can't quite get it nailed down. I'd appreciate any and all help :D

Sub SendEmails()
    Sheets("CODE").Select
    
    'Find last row in a dataset
    Dim lastRowCode As Long
    lastRowCode = Cells(Rows.Count, "A").End(xlUp).Row
    
     For i = 1 To lastRowCode
        If Range("C" & i) = "Yes" Then
            Sheets("DASHBOARD").Select
            Dim lastRowDash As Long
            lastRowDash = Cells(Rows.Count, "A").End(xlUp).Row
            ActiveSheet.Range("$A$1:$I$" & lastRowDash).AutoFilter Field:=8, Criteria1:= _
                Sheets("CODE").Range("A" & i).Value
                
                  
                  'Establishing the variables needed
                   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 EmailTo As String
                   Dim EmailSubject As String
                   Dim EmailAttachment As String
                   Dim EmailBody As String
                   Dim Signature As String
                
                   'Components of the Email, and their location in the "Email" Sheet
                   EmailTo = Sheets("CODE").Range("B" & i)
                   EmailSubject = ""
                   'Email Attachment Name
                   EmailAttachment = ""
                   'Formatting the Text of the Email Body
                   EmailBody = "[FONT=calibri]" & Replace(Sheets("CODE").Range("H1"), Chr(10), "") & "[/FONT]
"
                   
                   With Application
                       .ScreenUpdating = False
                       .EnableEvents = False
                   End With
                   Set Sourcewb = ActiveWorkbook
                   'Copy the "DASHBOARD" sheet to a new workbook
                   Sheets("DASHBOARD").Copy
                   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-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
                   'Change all cells in the worksheet to values if you want
                   With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                     End With
                     Application.CutCopyMode = False
                   'Save the new workbook/Mail it/Delete it
                   TempFilePath = Environ$("temp") & ""
                   TempFileName = EmailAttachment
                   Set OutApp = CreateObject("Outlook.Application")
                   Set OutMail = OutApp.CreateItem(0)
                   
                   'Adds Outlook signature to the end of your Email Body
                   With OutMail
                   .Display
                   End With
                   Signature = OutMail.HTMLBody
                         
                   'Creating and attaching the attachment, a sheet within the excel workbook, to the email with the desired name and password protection
                   With Destwb
                       .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum, ReadOnlyRecommended:=False _
                       , CreateBackup:=False
                       On Error Resume Next
                       'Composes the email
                       With OutMail
                           .To = EmailTo
                           .CC = ""
                           .BCC = ""
                           .Subject = EmailSubject
                           .HTMLBody = EmailBody & Signature
                           .Attachments.Add Destwb.FullName
                           'You can add other files also like this
                           '.Attachments.Add ("C:\test.txt")
                           'The next line will display the email before being sent
                           .Display   'or use .Display
                       End With
                       On Error GoTo 0
                       .Close savechanges:=False
                   End With
                   'Delete the file you have sent
                   Kill TempFilePath & TempFileName & FileExtStr
                   Set OutMail = Nothing
                   Set OutApp = Nothing
                   With Application
                       .ScreenUpdating = True
                       .EnableEvents = True
                   End With
            
            Sheets("DASHBOARD").Select
            ActiveSheet.Range("$A$1:$I$" & lastRowDash).AutoFilter Field:=8, Criteria1:= _
                Sheets("CODE").Range("A" & i).Value
            End If
             
             
        Next i
End Sub