Quick clean up of some VBA copy and paste code

[superskid]

I have the following VBA code and I just want to eliminate selecting the sheet that the data is pasting to and just pasting it directly there instead.

Maybe there is a way to clean up some of the paste specials at the same time? Thanks

Sub Pastedatatab()
'
' Pastedatatab Macro
'

'
    ActiveWorkbook.Unprotect "secret"
    Worksheets.Add(After:=Worksheets(1)).Name = "DataValues"
    Sheets("Data").Range("A1:AK369").Copy
    Sheets("DataValues").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    'Sheets("DataValues").Delete
    'ActiveWorkbook.Protect Password:="secret", Structure:=True, Windows:=False
End Sub

 

[ParamRay]

.
.

Sub CopyAndPaste()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    
    ActiveWorkbook.Unprotect Password:="secret"
    
    With ActiveWorkbook
        Set ws1 = .Worksheets("Data")
        Set ws2 = .Worksheets.Add(After:=ws1)
    End With
    
    ws1.Range("A1:AK369").Copy
    ws2.Name = "DataValues"
    
    With ws2.Range("A1")
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    
    Application.CutCopyMode = False
    
    ActiveWorkbook.Protect Password:="secret"

End Sub

 

[superskid]

Thanks, I inserted that into my existing code and now I have the following problem.

When the macro is done running it ends on the sheet after the data tab not where I was when I started running the macro? Sheet name I run the macro for is called "dashboard" but code is below.

Option Explicit

'This procedure will send the dashboard tab and a values pasted tab of the data tab
'to the emails listed on the email tab, the spreadsheet will be stripped of macros
'and sent as a *.xlsx file

Sub PasteValueMail()
'Working in 97-2007
    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 iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant
    Dim sh As Worksheet
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    'Unprotect worksheets to be copied to destination workbook
    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect
    Next ws
    
    'Take a values only copy of "data" tab
    Application.DisplayAlerts = False
    
    ThisWorkbook.Unprotect "secret"
        With ActiveWorkbook
        Set ws1 = .Worksheets("Data")
        Set ws2 = .Worksheets.Add(After:=ws1)
    End With
    
    ws1.Range("A1:AK369").Copy
    ws2.Name = "DataValues"
    
    With ws2.Range("A1")
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    
    Application.CutCopyMode = False
    

    Set Sourcewb = ActiveWorkbook

    'Copy the ActiveSheet to a new workbook
    'ActiveSheet.Copy

    'Or if you want to copy more then one sheet use:
    Sourcewb.Sheets(Array("Dashboard", "DataValues")).Copy
    
    ThisWorkbook.Sheets("DataValues").Delete
    ThisWorkbook.Protect Password:="secret", Structure:=True, Windows:=False
    
    'Protection back on for worksheets copied over to destination workbook
    For Each ws In ThisWorkbook.Worksheets
        ws.Protect
    Next ws

    Set Destwb = ActiveWorkbook

    'Change destination workbook to .xlsx,
    
    Application.DisplayAlerts = False
    
    With Destwb
            FileExtStr = ".xlsx": FileFormatNum = 51
    End With

    '    'Change all cells in Destwb 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
        Next sh
        Destwb.Worksheets(1).Select


    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sourcewb.Name & " - " & Format(Now, "mmm dd, yyyy")

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        .Close savechanges:=False
    End With

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "secret@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "secret"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"

        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Update
        End With
                     
        
    With iMsg
        Set .Configuration = iConf
        .To = Sheets("Email").Range("B2").Value & ";" & Sheets("Email").Range("B3").Value & ";" & Sheets("Email").Range("B4").Value & Sheets("Email").Range("B5").Value & ";" & Sheets("Email").Range("B6").Value & ";" & Sheets("Email").Range("B7").Value & Sheets("Email").Range("B8").Value & ";" & Sheets("Email").Range("B9").Value
        .CC = ""
        .BCC = ""
        .From = """Ron"" <ron@something.nl>"
        .Subject = "Dashboard"
        .TextBody = "Attached is the most recent dashboard"
        .AddAttachment TempFilePath & TempFileName & FileExtStr
        .Send
    End With


    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    Application.DisplayAlerts = True
End Sub

I've been just cutting and pasting a ton of code together so I'm sure it can be optimized, but on top of the macro ending on a different worksheet 2 more things are really bugging me.

1.) The spreadsheet that gets attached in the emails is caleed Filename.xlsm - Date.xlsx the first .xlsm does nothing and I would prefer to have that removed from the file name, what do I need to change?
2.) How do I change the subject to use the text in a cell from the workbook instead of a constant typed in quotations?

After that I think this is ready to be rolled out!

 

[superskid]

Solved number 2, just problem number 1 left!! I've tried everything to fix #1 but keep getting errors. Has to be a small change somewhere.

 

[Michael M]

duplicate post

http://www.mrexcel.com/forum/excel-...ctive-sheet-used-range-images-email-body.html

I have spent a significant amount of time assisting you with this project....please read the link below

Excelguru Help Site - A message to forum cross posters

 

[superskid]

Wasn't an intentional cross post. Started with VBA cleanup of totally separate macro that I decided to move into the other macro and make it one seamless step. My apologies.

 

[Michael M]

Did you try the code in the other thread ??

 

[superskid]

Yes, it named the file with the date only not just removing the .xlsm, but I was able to figure it out from that by just pulling in the values similar to the .To line of code.

Also implemented your cleanup of the value pasting. The workbook comes with the whole data values tab highlighted once you open it from email but it's more than good enough.

Thanks!

 

[Michael M]

Ok, glad it worked ...