Freeze pains in this VBA code I have pieced together

S

superskid

Board Regular
Joined
Aug 25, 2006
Messages
160
I have this giant macro that I have built by piecing together a ton of different examples and changing pieces by trial and error. First here is a quick summary of what the code does:

1.) This spreadsheet can take up to 20 minutes to calculate upon opening and it needs to be sent out daily to my executive team, emailing it is not an option

2.) The VBA code, copies the important tabs in a values format to a temporary workbook, and then emails out the temporary workbook automatically.

I have tried everything but I don't know how to do a pain freeze on the temporary workbook I email out. What I would like is on the tab in the temporary workbook called "datavalues" I would like the pane to be frozen at cell I5.

What do I need to add to the code in order to do this? Also if anyone of you experts spot some clean up that would be great, like I said this is over a years worth of daily tinkering and cutting and pasting for me.

Code: 
'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
    Dim ws3 As Worksheet
    Dim ws4 As Worksheet
    Dim ws5 As Worksheet
    Dim ws6 As Worksheet
    Dim ws7 As Worksheet
    Dim ws8 As Worksheet
    Dim x As Integer
    

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = 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", "Promo", and "ADP" tab
    ThisWorkbook.Unprotect "xxxxxxx"
        With ActiveWorkbook
        Set WS1 = .Worksheets("Data")
        Set ws2 = .Worksheets.Add(After:=WS1)
        Set ws3 = .Worksheets.Add(After:=ws2)
        Set ws4 = .Worksheets("ADP")
        Set ws5 = .Worksheets("promo")
        Set ws6 = .Worksheets.Add(After:=ws2)
        Set ws7 = .Worksheets("Email")
        Set ws8 = .Worksheets.Add(After:=ws6)
        
    End With
    
    WS1.Range("A1:AO500").Copy
    ws2.Name = "DataValues"
    
    With ws2.Range("A1")
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    
    Application.CutCopyMode = False
    
    ws4.Range("A1:K8000").Copy
    ws3.Name = "ADPValues"
    
    With ws3.Range("A1")
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    
    Application.CutCopyMode = False
    
    ws5.Range("A1:R400").Copy
    ws6.Name = "PromoValues"
    
    With ws6.Range("A1")
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    
    Application.CutCopyMode = False
    
    ws7.Range("A1:Z50").Copy
    ws8.Name = "EmailValues"
    
    With ws8.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", "ADPValues", "DataValues", "PromoValues", "EmailValues")).Copy
    
    ThisWorkbook.Sheets("DataValues").Delete
    ThisWorkbook.Sheets("ADPValues").Delete
    ThisWorkbook.Sheets("PromoValues").Delete
    ThisWorkbook.Sheets("EmailValues").Delete
    ThisWorkbook.Protect Password:="xxxxxxxxx", 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

    'Select cell A1 on each worksheet of destination workbook
    For x = Sheets.Count To 1 Step -1
        Set WS = Worksheets(x)
        WS.Activate
        Application.Goto Reference:=WS.Range("A1"), Scroll:=True
    Next
    
    'Change destination workbook to .xlsx,
    With Destwb
            FileExtStr = ".xlsx": FileFormatNum = 51
    End With

    '    'Change all cells in Destwb to values if you want
        For Each sh In Destwb.Worksheets
            With sh.UsedRange
                .Cells.Value = .Cells.Value
            End With
        Next sh
        
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sheets("Dashboard").Range("C4").Value & " Dashboard - " & Format(Sheets("Dashboard").Range("C2").Value, "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") = "xxxxxxxxxxx@xxxxxxxxxxx.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxxxxxxxxxx"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "xxxxxxxxxxx.xxxxxxxxxxx.com"

        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = xxxxxxxxxxx
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = xxxxxxxxxxx
        .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 & ";" & Sheets("Email").Range("B10").Value & ";" & Sheets("Email").Range("B11").Value & ";" & Sheets("Email").Range("B12").Value
        .CC = ""
        .BCC = ""
        .ReplyTo = Sheets("Email").Range("B4").Value
        .From = """Hudsons Reporting"" <xxxxxxxxxxx@xxxxxxxxxxx.com>"
        .Subject = Sheets("Dashboard").Range("C4").Value & " Dashboard - " & Format(Sheets("Dashboard").Range("C2").Value, "mmm dd, yyyy")
        .TextBody = "Attached is the " & Sheets("Dashboard").Range("C4").Value & " Dashboard run as at " & Format(Sheets("Dashboard").Range("C2").Value, "mmm dd, yyyy")
        .AddAttachment TempFilePath & TempFileName & FileExtStr
        .Send
    End With


    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    
    ThisWorkbook.Sheets("Dashboard").Select

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    
End Sub
</hudsonsreporting@gmail.com>
 
Last edited by a moderator:

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
Hi superskid,

To Freeze Panes, try adding these lines...
Code: 
 Set Destwb = ActiveWorkbook

 Application.Goto Reference:=Destwb.Sheets("DataValues").Range("I5")
 ActiveWindow.FreezePanes = True

It looks like the code can be streamlined in a few places.

Starting with the big picture, is there any reason that you can't start by making a temporary copy of your master workbook, then Paste as Values the data on its existing sheets?
That would seem simpler and faster than: add temp sheets > copy data > copy sheets > delete temp sheets.

Are the data sheets just for the recipients' reference? It doesn't seem like they are linked to the dashboard sheet that you send out unless you are remapping that in some way.
 
Last edited:
Upvote 0
Jerry Sullivan said:
Hi superskid,

To Freeze Panes, try adding these lines...
Code: 
 Set Destwb = ActiveWorkbook

 Application.Goto Reference:=Destwb.Sheets("DataValues").Range("I5")
 ActiveWindow.FreezePanes = True

It looks like the code can be streamlined in a few places.

Starting with the big picture, is there any reason that you can't start by making a temporary copy of your master workbook, then Paste as Values the data on its existing sheets?
That would seem simpler and faster than: add temp sheets > copy data > copy sheets > delete temp sheets.

Are the data sheets just for the recipients' reference? It doesn't seem like they are linked to the dashboard sheet that you send out unless you are remapping that in some way.
Click to expand...

Thanks!!



To answer your questions:

I guess there is no reason I can't start by making a temporary copy of the master workbook then paste values. The one thing is that by making a copy of it first it might try to re-pull the data before being able to paste it as values. The other tabs all use formulas to pull the data from my accounting software and can take 15 minutes at times to pull the whole workbook. That would certainly lock the macro up if it pulls the data on a new temporary copy.

The data sheets are just for the recipient's reference. If something on the "dashboard" tab looks off to them, they can go into the data and drill down without having to call me and ask what's going on.
 
Last edited:
Upvote 0
superskid said:
The one thing is that by making a copy of it first it might try to re-pull the data before being able to paste it as values. The other tabs all use formulas to pull the data from my accounting software and can take 15 minutes at times to pull the whole workbook.
Click to expand...

Well, an unintended update of the imported data is certainly something to be avoided. :eeek:

Try the code below and see if it triggers the update. If so, we can find a workaround.
The CDO parts are untested, but the rest worked for me.

Code: 
Sub PasteValueMail()
 Dim Destwb As Workbook
 Dim TempFilePath As String
 Dim TempFileName As String
 Dim FileExtStr As String
 Dim iMsg As Object
 Dim iConf As Object
 Dim vRecipients As Variant
 Dim sh As Worksheet
  
 Const sCONFIG_PATH As String = "http://schemas.microsoft.com/cdo/configuration/"
 
 '--only enable error handler after testing
 'On Error GoTo ErrProc
 
 With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
 End With
   
 '--copy sheets to a new workbook
 ThisWorkbook.Sheets(Array("Dashboard", "ADP", "Data", "Promo", "Email")).Copy
    
 Set Destwb = ActiveWorkbook

 '--process each sheet in Destwb
 For Each sh In Destwb.Worksheets
   With sh
      sh.Unprotect
      '--convert to values
      .UsedRange.Value = .UsedRange.Value
      '--select cell A1
      Application.Goto Reference:=sh.Range("A1"), Scroll:=True
   End With
 Next sh
  
 Application.Goto Reference:=Destwb.Sheets("Data").Range("I5")
 ActiveWindow.FreezePanes = True
    
 '--save the new workbook/Mail it/Delete it
 With Destwb
   TempFilePath = Environ$("temp") & "\"
   TempFileName = .Sheets("Dashboard").Range("C4").Value & " Dashboard - " _
      & Format(.Sheets("Dashboard").Range("C2").Value, "mmm dd, yyyy")
   FileExtStr = ".xlsx"
   .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=51
   .Close SaveChanges:=False
 End With

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

 iConf.Load -1    ' CDO Source Defaults

 With iConf.Fields
   .Item(sCONFIG_PATH & "smtpusessl") = True
   .Item(sCONFIG_PATH & "smtpauthenticate") = 1
   .Item(sCONFIG_PATH & "sendusername") = "xxxxxxxxxxx@xxxxxxxxxxx.com"
   .Item(sCONFIG_PATH & "sendpassword") = "xxxxxxxxxxx"
   .Item(sCONFIG_PATH & "smtpserver") = "xxxxxxxxxxx.xxxxxxxxxxx.com"
   .Item(sCONFIG_PATH & "sendusing") = xxxxxxxxxxx
   .Item(sCONFIG_PATH & "smtpserverport") = xxxxxxxxxxx
   .Update
 End With
                          
 '--read email addresses into array
 vRecipients = Application.Transpose(ThisWorkbook.Sheets("Email").Range("B2:B12").Value)
 
 With iMsg
   Set .Configuration = iConf
   .To = Join(vRecipients, ";")
   .CC = ""
   .BCC = ""
   .ReplyTo = vRecipients(3)
   .From = """Hudsons Reporting"" "
   .Subject = TempFilePath & TempFileName
   .TextBody = "Attached is the " & Sheets("Dashboard").Range("C4").Value _
      & " Dashboard run as at " & Format(Sheets("Dashboard").Range("C2").Value, "mmm dd, yyyy")
   .AddAttachment TempFilePath & TempFileName & FileExtStr
   .Send
 End With
    
 ThisWorkbook.Sheets("Dashboard").Select

 '--delete the file you have sent
 Kill TempFilePath & TempFileName & FileExtStr

ExitProc:
 With Application
   .ScreenUpdating = True
   .EnableEvents = True
   .DisplayAlerts = True
   .Calculation = xlCalculationAutomatic
 End With
 Exit Sub

ErrProc:
 MsgBox Err.Number & ": " & Err.Description
 Resume ExitProc
End Sub
 
Last edited by a moderator:
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
CDO_Mail_Small_Text Run time error
Replies
0
Views
111
Louis chiron
L
M
  • Question Question
Email file VBA - change attachment from excel to PDF?
Replies
2
Views
233
MOB
M
H
  • Question Question
Macro to email Report
Replies
2
Views
529
howard
H
B
  • Solved
VBA copy Values exclude 1 column and formula
Replies
2
Views
274
bombergirl61
B
S
  • Question Question
VBA to email multiple ranges on a sheet.
Replies
0
Views
501
shophoney
S

Forum statistics

Threads
1,223,268
Messages
6,171,100
Members
452,379
Latest member
IainTru

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top