Thread: Copy range to new workbook, save and email

Hi

I am trying to get my macro working. It essentially copies to a new workbook the 8 ranges from my original workbook to columns A to I starting at row 2. Row 1 is renamed with different titles. The new Workbook is then saved to the desktop with the name depicted by the windows login, data and time. This file is then attached to an email and sent to an email address with the subject OCP and the date as the subject.

Here is the code I have so far, I am getting an debug error currently.

Sub EMAILnSAVE()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFileName As String
Dim cell    As Long
Dim NR      As Long
Dim wsData  As Worksheet
Dim wsCSV   As Worksheet
Dim SaveStr As String

Application.Workbooks.Add
Set Destwb = ActiveWorkbook
    
With Destwb
    Worksheets("Sheet1").Select
    With Selection
        .Range("A1") = "EMP_ID"
        .Range("B1") = "KnownAs"
        .Range("C1") = "JobTitle"
        .Range("D1") = "LineManager"
        .Range("E1") = "ReportedSick"
        .Range("F1") = "StartDate"
        .Range("G1") = "EndDate"
        .Range("H1") = "Comments"
        .Range("A2").Name = "Area"
    End With

Set Sourcewb = ActiveWorkbook

Set wsData = Sheets("OUTPUT")
Set wsCSV = Worksheets.Add(After:=Sheets(Sheets.Count))

With Application
   .ScreenUpdating = False
   .EnableEvents = False
End With

    With wsData

        .Range("A2:A" & Range("A1").End(xlDown).Row).Select
        .Range("B2:B" & Range("A1").End(xlDown).Row).Select
        .Range("E2:E" & Range("A1").End(xlDown).Row).Select
        .Range("G2:G" & Range("A1").End(xlDown).Row).Select
        .Range("I2:I" & Range("A1").End(xlDown).Row).Select
        .Range("J2:J" & Range("A1").End(xlDown).Row).Select
        .Range("K2:K" & Range("A1").End(xlDown).Row).Select
        .Range("L2:L" & Range("A1").End(xlDown).Row).Select
        
            Selection.Copy
    End With

With Destwb
Destwb.Range("Area").Activate
    Selection.Paste
    
   If Val(Application.Version) < 12 Then
      ' You are using Excel 97-2003.
      FileExtStr = ".xls": FileFormatNum = -4143
   Else
         Select Case Sourcewb.FileFormat
            ' Code 51 represents the enumeration for a macro-free
            ' Excel 2007 Workbook (.xlsx).
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            ' Code 52 represents the enumeration for a
            ' macro-enabled Excel 2007 Workbook (.xlsm).
            Case 52:
                  FileExtStr = ".xlsm": FileFormatNum = 52
            ' Code 56 represents the enumeration for a
            ' a legacy Excel 97-2003 Workbook (.xls).
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            ' Code 50 represents the enumeration for a
            ' binary Excel 2007 Workbook (.xlsb).
             Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
         End Select
   End If
End With

SaveStr = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
        & Application.PathSeparator _
        & ActiveSheet.Name _
        & Environ("USERNAME") _
        & " - " _
        & Format(Now, " d-m-yy h.m AM/PM")

With Destwb
   .SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
      On Error Resume Next
   .SendMail "me@myemail.ac.uk", _
      "OCP" & Format(Now, "d-m-yy")
      On Error GoTo 0
   .Close SaveChanges:=False
End With
 
With Application
   .ScreenUpdating = True
   .EnableEvents = True
End With
ActiveWorkbook.Close False
Worksheets("INPUT").Activate
End Sub

You appear to be missing an End With line.

This is what I have now but I am still getting an error?

Sub EMAILnSAVE()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFileName As String
Dim cell    As Long
Dim NR      As Long
Dim wsData  As Worksheet
Dim wsCSV   As Worksheet
Dim SaveStr As String

Set Sourcewb = ActiveWorkbook
Set wsData = Sheets("OUTPUT")
Set wsCSV = Worksheets.Add(After:=Sheets(Sheets.Count))

With Application
   .ScreenUpdating = False
   .EnableEvents = False
End With

Application.Workbooks.Add
Set Destwb = ActiveWorkbook
    
With Destwb
    Worksheets("Sheet1").Select
    With Selection
        .Range("A1") = "EMP_ID"
        .Range("B1") = "KnownAs"
        .Range("C1") = "JobTitle"
        .Range("D1") = "LineManager"
        .Range("E1") = "ReportedSick"
        .Range("F1") = "StartDate"
        .Range("G1") = "EndDate"
        .Range("H1") = "Comments"
        .Range("A2").Name = "Area"
    End With
End With

With Sourcewb
    wsData.Select
        With Selection
            .Range("A2:A" & Range("A1").End(xlDown).Row).Copy
            .Range("B2:B" & Range("A1").End(xlDown).Row).Copy
            .Range("E2:E" & Range("A1").End(xlDown).Row).Copy
            .Range("G2:G" & Range("A1").End(xlDown).Row).Copy
            .Range("J2:J" & Range("A1").End(xlDown).Row).Copy
            .Range("K2:K" & Range("A1").End(xlDown).Row).Copy
            .Range("L2:L" & Range("A1").End(xlDown).Row).Copy
        End With
End With

With Destwb
    Destwb.Range("Area").Paste
    
   If Val(Application.Version) < 12 Then
      ' You are using Excel 97-2003.
      FileExtStr = ".xls": FileFormatNum = -4143
   Else
         Select Case Sourcewb.FileFormat
            ' Code 51 represents the enumeration for a macro-free
            ' Excel 2007 Workbook (.xlsx).
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            ' Code 52 represents the enumeration for a
            ' macro-enabled Excel 2007 Workbook (.xlsm).
            Case 52:
                  FileExtStr = ".xlsm": FileFormatNum = 52
            ' Code 56 represents the enumeration for a
            ' a legacy Excel 97-2003 Workbook (.xls).
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            ' Code 50 represents the enumeration for a
            ' binary Excel 2007 Workbook (.xlsb).
             Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
         End Select
   End If
End With

SaveStr = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
        & Application.PathSeparator _
        & ActiveSheet.Name _
        & Environ("USERNAME") _
        & " - " _
        & Format(Now, " d-m-yy h.m AM/PM")

With Destwb
   .SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
      On Error Resume Next
   .SendMail "me@myemail.ac.uk", _
      "OCP" & Format(Now, "d-m-yy")
      On Error GoTo 0
   .Close SaveChanges:=False
End With
 
With Application
   .ScreenUpdating = True
   .EnableEvents = True
End With
ActiveWorkbook.Close False
Worksheets("INPUT").Activate
End Sub

Care to give us a clue what error and where?

For starters, what are you supposed to be pasting? You haven't copied anything in that code.

You can't select a sheet that's not in the active workbook.
Ignore my previous question about copying - I was looking at the original code. The new question about copying is why are you copying 7 ranges one after the other without pasting them anywhere?

No need to activate or Select generally. Try this (untested) version:

Sub EMAILnSAVE()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFileName As String
    Dim cell    As Long
    Dim NR      As Long
    Dim wsData  As Worksheet
    Dim wsCSV   As Worksheet
    Dim SaveStr As String
    
    On Error GoTo err_handle
    
    With Application
       .ScreenUpdating = False
       .EnableEvents = False
    End With
    
    Set Sourcewb = ActiveWorkbook
    With Sourcewb
        Set wsData = .Sheets("OUTPUT")
        Set wsCSV = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
    End With
    
    Set Destwb = Application.Workbooks.Add
        
    With Destwb.Worksheets("Sheet1")
        .Range("A1") = "EMP_ID"
        .Range("B1") = "KnownAs"
        .Range("C1") = "JobTitle"
        .Range("D1") = "LineManager"
        .Range("E1") = "ReportedSick"
        .Range("F1") = "StartDate"
        .Range("G1") = "EndDate"
        .Range("H1") = "Comments"
        .Range("A2").Name = "Area"
    End With
    
    With wsData
        NR = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A2:B" & NR & ",E2:E" & NR & ",G2:G" & NR & ",J2:L" & NR).Copy Destination:=Destwb.Range("Area")
    End With

   If Val(Application.Version) < 12 Then
      ' You are using Excel 97-2003.
      FileExtStr = ".xls": FileFormatNum = -4143
   Else
        Select Case Sourcewb.FileFormat
        
           ' Code 51 represents the enumeration for a macro-free
           ' Excel 2007 Workbook (.xlsx).
           Case 51
                FileExtStr = ".xlsx"
                FileFormatNum = 51
                
           ' Code 52 represents the enumeration for a
           ' macro-enabled Excel 2007 Workbook (.xlsm).
           Case 52
                 FileExtStr = ".xlsm"
                 FileFormatNum = 52
           
           ' Code 56 represents the enumeration for a
           ' a legacy Excel 97-2003 Workbook (.xls).
           Case 56
                FileExtStr = ".xls"
                FileFormatNum = 56
           ' Code 50 represents the enumeration for a
           ' binary Excel 2007 Workbook (.xlsb).
            Case Else
                FileExtStr = ".xlsb"
                FileFormatNum = 50
        End Select
   End If

    SaveStr = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
            & Application.PathSeparator _
            & ActiveSheet.Name _
            & Environ("USERNAME") _
            & " - " _
            & Format(Now, " d-m-yy h.m AM/PM")
    
    With Destwb
       .SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
          On Error Resume Next
       .SendMail "me@myemail.ac.uk", _
          "OCP" & Format(Now, "d-m-yy")
          On Error GoTo err_handle
       .Close SaveChanges:=False
    End With
    
    ' not sure which workbook you are trying to close here?
    'ActiveWorkbook.Close False
    
 
clean_up:
    With Application
       .EnableEvents = True
       .ScreenUpdating = True
    End With
    Exit Sub

err_handle:
    MsgBox Err.Description
    Resume clean_up
End Sub

Note: I added an error handler as you should always have one if you turn events off.

Again, what error?
I don't see how that could get stuck in a loop since it exits after an error.