Email:      Pass:    Pass?


Advertisements


Free Excel Forum

Create New Folder & Save As

Forum Register
Search Excel Forum Posts, Tutorials, Macros, Tips, and More

Hi,

I have the following code. I am having trouble with the creat folder and save new workbook as. I want to create a folder named USD (USD is a value in the Sheet named ADMIN Cell B3. I then want to save each new workbook as the worksheet name & the currency from Sheet ADMIN Cell B3 & the year which is in Sheet ADMIN Cell B2.

My code is below. I am having trouble with the folder and the naming of the files.

Code:

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2010
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

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

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd")
    FolderName = Sourcewb.Path & "\" & Worksheet & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            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-2010
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        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 If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


               'Save the new workbook and close it
            With Destwb
                 .SaveAs FolderName _
                        & Sheets("ADMIN").Range("B2").Value _
                        & Sheets("ADMIN").Range("B3").Value _
                        & "\" & .Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub





Similar Excel Video Tutorials

Helpful Excel Macros

Complete Guide to Printing in Excel Macros - PrintOut Method in Excel
- This free Excel macro illustrates all of the possible parameters and arguments that you can include in the PrintOut Meth
Name Worksheets Based on Cell Contents
- This macro allows you to have your worksheets named by whatever is in a particular cell within a worksheet. This means
Delete All Chart Sheets in Excel - Only Chart Sheets are Deleted - Not Embedded Charts
- Delete all chart sheets and tabs in Excel using this macro. This will only delete the charts and graphs that are in the
Combine Multiple Workbooks into One
- This macro for Microsoft Excel allows you to combine multiple workbooks and worksheets into one new workbook and workshe
Replace Formulas with Values (For The Entire Workbook)
- This macro will convert every formula in an entire workbook into its respective value. This is basically a quick way to

Similar Topics







Hi,

I have the code got from
http://www.rondebruin.nl/copy6.htm Code:

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

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

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            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
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        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 If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub


works really fine for me.
However I want to skip 2 sheets called " Data" and "Master" and save the rest.

Thanks
Arvind


Hi all

I have another little conumdrum I'm trying to work out.

I'm using one of Ron's scripts as an add-in which I've just amended the output path for.

http://www.rondebruin.nl/tips.htm

This script essentially creates a new workbook from each worksheet in the active workbook.

As I have a workbook of about 500 worksheets, I am trying to group the worksheets opposed to having to split all and rejoin them manually.

Luckily all of my worksheets names are initials with numbers after them (as assigned by excel when merged):

e.g., RH, RH (2), RH (3), RH (4), AG, AG (2), AG (3) and so on.

That said there are some random ones too, but I'm happy for them to be kicked out as individual files.

Anyway I'm pretty sure there is a way this can be added into this existing script by addressing Sheet.Name perhaps but I'm a bit unsure exactly..

Sorted in order (i.e. 2,3,4) would also be a bonus but not essential as they need to manually checked and I have a separate macro for sorting worksheets anyway.

Any input would be much appreciated!!

Cheers

Danny

Code:

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

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

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ActiveWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "(dd-mm-yy)")
    FolderName = "F:\General Docs\Output" & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            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
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        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 If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub





Hi,

I have a macro populates a templatete from sheet 2 first row.
I have given some formulas in template to take values from row of sheet2.
and then it saves the template as new workbook.
I am not sure how do I loop through all the rows in sheet2. that is I have input formula in Tempalte file cell H5 as = Data!A2 and so on...( all the data comes from the same row. for the next template, it has to pick up data from row 2 of sheet2, for the next template row3 of sheet2 and so on..

here is the code I have:
Code:

' code taken from rondebruine site.
Option Explicit
Sub CopySheet_To_New_Workbook()
'Working in 97-2007
Sheets("Template").Select

    Range("H5:K5").Select
    ActiveCell.FormulaR1C1 = "=Data!R[-3]C[-7]"
    Range("H7:K7").Select
    ActiveCell.FormulaR1C1 = "=Data!R[-5]C[-6]"
    Range("H9:K9").Select
    ActiveCell.FormulaR1C1 = "=Data!R[-7]C[-5]"
    Range("I12").Select
    Range("H11:K11").Select
    ActiveCell.FormulaR1C1 = "=Data!R[-9]C[-4]"
    ActiveCell.FormulaR1C1 = "=Data!R[-10]C[-3]"
    Range("H13").Select
    ActiveCell.FormulaR1C1 = "=Data!R[-11]C[-1]"
    Range("H14:K14").Select
    ActiveCell.FormulaR1C1 = "=Data!R[-12]C"
    Range("F17:L17").Select
    ActiveCell.FormulaR1C1 = "=Data!R[-15]C[-1]"
    Range("F18").Select
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
 
    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook
 
    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName
 
    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        '// Not tested, but I believe a quick check here should do it.//
        If Not sh.Name = "Data" Then
        'And Not sh.Name = "Master Sheet" then
        
        
            'If the sheet is visible then copy it to a new workbook
            If sh.Visible = -1 Then
                sh.Copy
    
                'Set Destwb to the new workbook
                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
                        If Sourcewb.Name = .Name Then
                            MsgBox "Your answer is NO in the security dialog"
                            GoTo GoToNextSheet
                        Else
                            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 If
                End With
    
                'Change all cells in the worksheet to values if you want
                If Destwb.Sheets(1).ProtectContents = False Then
                    With Destwb.Sheets(1).UsedRange
                        .Cells.Copy
                        .Cells.PasteSpecial xlPasteValues
                        .Cells(1).Select
                    End With
                    Application.CutCopyMode = False
                End If
    
                'Save the new workbook and close it
                With Destwb
                    .SaveAs FolderName _
                          & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                            FileFormat:=FileFormatNum
                    .Close False
                End With
    
            End If
        End If
GoToNextSheet:
    Next sh
 
    MsgBox "You can find the files in " & FolderName
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub


Thanks for your help...
Arvind


Hi,

I got the below code from http://www.rondebruin.nl/copy6.htm site. I just need some minor changes on the code. This code creates all the sheets into new workbooks. I have about 75 sheets in my workbook, so when I run the macro, I am getting 75 workbooks.
What I need is I have 3 sheets which I dont want to create a as workbook,
the sheet names are, Data, Emailsheet & Approval Register.
Except these 3 sheets all other sheets should be converted into workbooks.

the code is
Code:

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

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

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            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
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        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 If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub


Arvind...


Hello Excel gurus

I'm working on a macro that would separate worksheets from one workbook into individual files, but I'm running into a problem with the infamous 255 characters limitation in Excel 2003.

Everything works fine, but one of the cells usually has more than 255 characters, and when the worksheets are copied this cell is truncated to 255 chars... Is there a way to overcome this?

The cell that is causing me problems is a merged range of C11:L11 (this is fixed for all sheets)

Here is the macro code:

Code:

Sub SeparateSheets()
Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    Set Sourcewb = ActiveWorkbook


    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName


    For Each sh In Sourcewb.Worksheets


        If sh.Visible = -1 Then
            sh.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
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        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 If
            End With


            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If



            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With


End Sub





I am using the code below to create new workbooks from individual worksheets in a single workbook, and currently use the line:

Code:

 FileExtStr = ".xls": FileFormatNum = 56 


to specify it save the document in compatible 97-2003 format, it works the same for these:

Code:

 FileExtStr = ".xlsb": FileFormatNum = 50  
 FileExtStr = ".xlsx": FileFormatNum = 51 
 FileExtStr = ".xlsm": FileFormatNum = 52 


Is it possible to create a prompt at the beginning of the macro to give the user four options ie:

Please select format:
Excel 2007 (xlsx)
Excel 2007 Macro Enabled (xlsm)
Excel 2007 Binary (xlsb)
Excel 97-2003 Compatible (xls)



Code:

 
Sub Copy_Every_Sheet_To_New_Workbook()
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    Set Sourcewb = ThisWorkbook
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName
    For Each sh In Sourcewb.Worksheets
        If sh.Visible = -1 Then
            sh.Copy
            Set Destwb = ActiveWorkbook
            With Destwb
                If Val(Application.Version) < 12 Then
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        FileExtStr = ".xls": FileFormatNum = 56
                    End If
                End If
            End With
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If
 
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With
        End If
GoToNextSheet:
    Next sh
    MsgBox "You can find the files in " & FolderName
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub


Thanks for any help or pointers!


Using this code from Ron de Bruin to e-mail one sheet from many in a workbook. Three questions...#1 - how would I select and mail only the last sheet in the workbook or #2 - allow user to enter the unique sheet name (one of many) to select and mail only that sheet. #3 - Would like to put the unique sheet name in the e-mail subject line after "MIR #_____.

Code:

Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String

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

    Set Sourcewb = ActiveWorkbook

    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    With Destwb
        If Val(Application.Version) < 12 Then
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 If
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail "", _
                  "MIR #"
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

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





Hi,

I used a code in this thread contributed by Giant_Cheeseman to copy a sheet from my workbook and automatically copy it (and create) a new workbook. The code also allows me to save the name of the new workbook as specify in the cell.

However, I was wondering if there's anyway for me to not have the Compile button to be copied to the new workbook. Because right now, the button will be copied along with everything else.

Attached is the excel file.

This is the code used.

Code:

Sub saveas_new_workbook()

'Working in Excel 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

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

    Set Sourcewb = ActiveWorkbook
    
    'Copy the sheet to a new workbook
    ActiveSheet.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
            'We exit the sub when your answer is NO in the security dialog that you
            'only see when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 If
    End With

    '    'If you want to change all cells in the worksheet to values, uncomment these lines.
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    'Save the new workbook as cell value H13 and close it
    ActiveSheet.Name = Range("H13").Value
    '      Change the following default folder
    TempFilePath = "C:\INVOICES" & "\"
    TempFileName = ActiveSheet.Range("H13").Text
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        .Close SaveChanges:=False
    End With
   '     Messagebox indicates completion of process (due to file closing after processing)
    MsgBox "You can find the new file in " & TempFilePath
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub





hi all,

The following macro has a problem. It is sending the attachment with double file extension. For e.g. if the excel filename is abc.xls, the attached file is sent as abc.xls.xls. The macro is used to send a single sheet instead of the entire workbook as an attachment.

Any help would be greatly appreciated.

Code:

Sub Mail_ActiveSheet()
'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
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
 
    'Copy the sheet to a new workbook
    ActiveSheet.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
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 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 = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
 
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail "ron@debruin.nl", _
                  "This is the Subject line"
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub





Hey Guys,

This is my first post. Iam busy in a workbook with a lot of sheets. Now I want these sheet in a separate files. So from all worksheets to workbooks. I found the code you can see beneath. This works. The only problem is that certain cells especially the ones with a lot of text are not fully copied from worksheet to the new workbook! When I copy with ctrl a then ctrl c then ctrl v at a new workbook everything is going well. How can i solve this?

Here's the code:
Code:

Sub Creeer_werkblad_per_sheet()

'Working in 97-2007
    Application.Run "onzichtbaarmaken"

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

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

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "\\nl\netwerkmappen\PersoonlijkeData\" & Worksheets("Start").Range("e6") & "\Project rapportages"

    'Copy every visible sheet to a new workbook
            For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
        sh.Copy
        
            'Set Destwb to the new workbook
            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
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        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 If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
                     .Cells.PasteSpecial xlPasteFormats, Operation:= _
                        xlNone, SkipBlanks:=False, Transpose:=False
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
'celinhoud die samengevoegd moet worden
    Range("C34:Q38").Select
    ActiveWindow.SmallScroll Down:=12
    Range("C34:Q38,S34:S38,U34:U38,C41:Q43,S41:S43,U41:U43").Select
    Range("U41").Activate
    ActiveWindow.SmallScroll Down:=24
    Range( _
        "C34:Q38,S34:S38,U34:U38,C41:Q43,S41:S43,U41:U43,C66:Q71,S66:S71,U66:U71,C79:U82,C85:U88" _
        ).Select
    Range("C85").Activate
    With Selection
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    Range("a1").Select
    End With
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & "   " & Range("d2").Formula & "   " & "- " & Range("u3").Formula & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "Je kan de bestanden vinden in:  " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
        Application.Run "zichtbaarmaken"
End Sub





Hey Guys,

This is my first post. Iam busy in a workbook with a lot of sheets. Now I want these sheet in a separate files. So from all worksheets to workbooks. I found the code you can see beneath. This works. The only problem is that certain cells especially the ones with a lot of text are not fully copied from worksheet to the new workbook! When I copy with ctrl a then ctrl c then ctrl v at a new workbook everything is going well. How can i solve this?

Here's the code:
Code:

Sub Creeer_werkblad_per_sheet()

'Working in 97-2007
    Application.Run "onzichtbaarmaken"

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

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

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "\\nl\netwerkmappen\PersoonlijkeData\" & Worksheets("Start").Range("e6") & "\Project rapportages"

    'Copy every visible sheet to a new workbook
            For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
        sh.Copy
        
            'Set Destwb to the new workbook
            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
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        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 If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
                     .Cells.PasteSpecial xlPasteFormats, Operation:= _
                        xlNone, SkipBlanks:=False, Transpose:=False
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
'celinhoud die samengevoegd moet worden
    Range("C34:Q38").Select
    ActiveWindow.SmallScroll Down:=12
    Range("C34:Q38,S34:S38,U34:U38,C41:Q43,S41:S43,U41:U43").Select
    Range("U41").Activate
    ActiveWindow.SmallScroll Down:=24
    Range( _
        "C34:Q38,S34:S38,U34:U38,C41:Q43,S41:S43,U41:U43,C66:Q71,S66:S71,U66:U71,C79:U82,C85:U88" _
        ).Select
    Range("C85").Activate
    With Selection
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    Range("a1").Select
    End With
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & "   " & Range("d2").Formula & "   " & "- " & Range("u3").Formula & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "Je kan de bestanden vinden in:  " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
        Application.Run "zichtbaarmaken"
End Sub





Hey y'all,

I'm looking to use the following code to send an activate worksheet. But the problem is email address needs to be entered into the code. I want it to find an email address which will be in cell "G36" because the email address will change with different worksheets. Can you help....

Code:

Sub Mail_ActiveSheet()
'Working in 97-2010
    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 I As Long

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

    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.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-2010, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 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 = "Part of " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        For I = 1 To 3
            .SendMail "peeandpoo@bigpond.com", _
                      "This is the Subject line"
            If Err.Number = 0 Then Exit For
        Next I
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

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

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





Hey Guys,

This is my first post. Iam busy in a workbook with a lot of sheets. Now I want these sheet in a separate files. So from all worksheets to workbooks. I found the code you can see beneath. This works. The only problem is that certain cells especially the ones with a lot of text are not fully copied from worksheet to the new workbook! When I copy with ctrl a then ctrl c then ctrl v at a new workbook everything is going well. How can i solve this?

Here's the code:
Code:

Sub Creeer_werkblad_per_sheet()

'Working in 97-2007
    Application.Run "onzichtbaarmaken"

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

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

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "\\nl\netwerkmappen\PersoonlijkeData\" & Worksheets("Start").Range("e6") & "\Project rapportages"

    'Copy every visible sheet to a new workbook
            For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
        sh.Copy
        
            'Set Destwb to the new workbook
            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
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        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 If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
                     .Cells.PasteSpecial xlPasteFormats, Operation:= _
                        xlNone, SkipBlanks:=False, Transpose:=False
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
'celinhoud die samengevoegd moet worden
    Range("C34:Q38").Select
    ActiveWindow.SmallScroll Down:=12
    Range("C34:Q38,S34:S38,U34:U38,C41:Q43,S41:S43,U41:U43").Select
    Range("U41").Activate
    ActiveWindow.SmallScroll Down:=24
    Range( _
        "C34:Q38,S34:S38,U34:U38,C41:Q43,S41:S43,U41:U43,C66:Q71,S66:S71,U66:U71,C79:U82,C85:U88" _
        ).Select
    Range("C85").Activate
    With Selection
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    Range("a1").Select
    End With
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & "   " & Range("d2").Formula & "   " & "- " & Range("u3").Formula & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "Je kan de bestanden vinden in:  " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
        Application.Run "zichtbaarmaken"
End Sub





Good morning-
I have a macro set up and tied to a command button that will automatically attach the spreadsheet to an email. Is there anyway to automatically have an email address added to the cc field of the email?

Here is the current macro:
Code:

Sub Mail_Sheets_Array4()
'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 sh As Worksheet
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
 
    'Copy the sheets to a new workbook
    Sourcewb.Sheets(Array("Quote")).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
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy sheets from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 If
    End With
 
    '    'Change all cells in the worksheets 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
    '        Destwb.Worksheets(1).Select
    '    Next sh
 
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
 
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail "", _
                  "Financing Quote"
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub


I actually had help with this macro from a previous post on this forum so am not to familiar with the ins and outs that make it work. TIA!


Hi All,

I am trying to utilise the code below to send a worksheet in pdf format attached to an outlook email.

I need to edit the code below to enable me to send a specific worksheet as it currently send the active worksheet.

Also I want to send the worksheet to a list of email addresses that are on another worksheet

I would be grateful if anyone could tell me how I do this.

Many thanks



Neil



Code:

 

Sub Mail_ActiveSheet()
'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

 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
 
    'Copy the sheet to a new workbook
    ActiveSheet.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
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 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 = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
 
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail neil@neilfearnley.co.uk, _
                  "This is the Subject line"
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub





Ok, this is practically done but with one exception. The file which I want to send as a CSV needs to be named in a certain way. It would be the contents of cell A2, then the date it was sent and the time. Here is my current code. How can I get it to pick up data from a cell and then add it to the list. Also, the list has to be one string, so for example, 23459 Cell A2, 1310 Date and 192859 would be time. So the renamed file would be named 234591310192859. Here is my code which may make what I'm saying a bit more into a bit more sense. Currently the name which is outputted is 'Name of Spreadsheet.xls 13-Jan-10 19-31-59'.

Code:

Sub Mail_ActiveSheet()
'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

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

    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.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
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 = ".csv": FileFormatNum = 6
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        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 = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail "Joe Bloggs@Hextex.com", _
                  "Thank you for the order"
        On Error GoTo 0
        .Close savechanges:=False
    End With

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

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


Any help would be truly appreciated.

Thank You


Code:

Sub Mail_ActiveSheet()
'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

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

    Set Sourcewb = ActiveWorkbook
    Sheets("Randprices").Unprotect Password:="rand"

    'Copy the sheet to a new workbook
    ActiveSheet.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, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 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 = "Part of " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail "Dan@scottcooper.com", _
                  "Order Attached"
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

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

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


The following code unlocks the master sheet (Randprices), copies values only to a new workbook, emails new workbook, deletes new workbook. The only problem I have is that I need to relock the master sheet (randprices) after exporting data to a new sheet. I belive the code is:


Sheets("Randprices").Protect Password:="rand"

just don't know where to stick it to make it happen. I put it at the end, but it locked the exported sheet not the master. Any clues????


I have the following code (that I borrowed) and was using it to export some worksheets to a new workbook. It worked fine for about 4 times, now it says it can't find the file path and stops on the "MkDir FolderName" line.

Code:

Sub ExportWorkbook()
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    
For Each sh In ThisWorkbook.Worksheets
With sh
    If LCase(Right(.Name, 2)) = "sd" Then
        .Visible = xlSheetVisible
    End If
End With
Next sh
Sheets("Order").Visible = xlSheetHidden

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

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "mm-dd-yyyy hh:mm")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
     MkDir FolderName 

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy
        'and so on


The sourcewb is in a folder on my desktop. When this worked correctly, it created a new folder within that same folder. (I haven't moved anything.) That would be great but I'm over my head here... Any help is greatly appreciated. Thank you!


Hi, I am using the code below that I got off of these forums to email a particular sheet in my workbook, but I need to strip all of the VBA code and the command button from the sheet being sent. Is this possible?

Code:

Sub Mail_ActiveSheet()
'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
    
res = InputBox("Please enter the e-mail address you wish to send this to:")
EmailAddress = res

 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
 
    'Copy the Invoice and Analysis sheets to a new workbook
    ActiveSheet.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
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 If
    End With
  
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Temp File Name"

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        
        On Error Resume Next
        .SendMail EmailAddress, _
                  "E-mail From Excel"
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub


Thanks!
Clayton Grove


Dear Experts,

I have pulled a massive report into excel. it is having a state_colum by default it is the first column. I have got two macros which I got from the web. 1st one is on the basis of colum1 cell value it will create different wook sheet and in the 2nd macro is it will convert those work sheets in to work book. I dont know VB and i am not aware of creating an user friendly addin for working this two macros. The state colum will change from 1st colum to some other column in some other report.

Can some body help to make an adding by which it will aks which is the state coulm and depending on the inputs ie colum number this function should work. If the state coulm comes in colum 4 it should work according to coulm 4 etc. Please find below the macro i have. It has to ask whether you want to convert to different work book also.
pls find my email id. exceltestfile@rediffmail.com

Thanks in advance.
Note : basically it should ask three question according to answers it should work.

1. which is the state colum number
2. Want to convert to different sheet
3. want to convert to different work book







StateColumn = 1
Set SourceSheet = ActiveSheet
For N = 2 To Cells(65536, 1).End(xlUp).Row
If Cells(N, StateColumn) Cells(N - 1, StateColumn) Then
Sheets.Add after:=Sheets(Sheets.Count)
SourceSheet.Activate
Sheets(Sheets.Count).Name = Cells(N, StateColumn)
Rows(1).Copy Destination:=Sheets(Sheets.Count).Rows(1)
End If
Rows(N).Copy Destination:=Sheets(Sheets.Count).Cells(65536, StateColumn).End(xlUp).Offset(1, 0)
Next N
End Sub

The second macro is as below.


Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

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

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy

'Set Destwb to the new workbook
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
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
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 If
End With

'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If


'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With

End If
GoToNextSheet:
Next sh

MsgBox "You can find the files in " & FolderName

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub


I have searched and learned a lot about mailing but am stuck. I read many of Ron De Bruin's information and got as far as I did because of that information. I am getting a compile error "for without next". I don't know where to put the "Next" and I added the "for" coding so I'm sure there is something wrong there also. Column "L" on the active sheet is where the emails are going to populate. Could someone please take a look and fix my code? Thank you in advance. Cindy

Code:

Sub Mail_ActiveSheet()
'Working in 2000-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 OutApp As Object
    Dim OutMail As Object
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
 
    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
 
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 2000-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 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 = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
 
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
 
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
    
    For Each Cell In Sh.Column("L")
    
        If Cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(Rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
      
        With OutMail
            .To = "cell.value"
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send   'or use .Display
         End With
    
        On Error GoTo 0
        .Close SaveChanges:=False
    End If
    
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    Set OutMail = Nothing
    Set OutApp = Nothing
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub





I am using the code below to copy a sheet to new file end send via email. As I have some vba code in the sheet which I am coping I need to delete before sending.

Code:

Sub SendEmail()
'Working in 2000-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 OutApp As Object
    Dim OutMail As Object

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


    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
    
         

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 2000-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 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 = Sourcewb.Name
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = "email.com"
            .CC = ""
            .BCC = ""
            .Subject = "test me"
            .Body = "Hi there"
            .Attachments.Add Destwb.FullName
            
            .Display
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

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

    Set OutMail = Nothing
    Set OutApp = Nothing

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


I found on the net that if I add this line to the code, it will delete the vba from the sheet

Code:

Destwb.VBProject.VBComponents(activesheet.CodeName).CodeModule.DeleteLines
1, Destwb.VBProject.VBComponents(activesheet.CodeName).CodeModule.CountOfLines


But it keeps giving me an error.

Any ideas?


Hi,

I have code below for sending e-mail of an excel sheet.

It creates name file name of the workbook being sent out, But I want the file name to include a specific text from the sourceworkbook.

Is that possible.

eg. to include sheet1.range("A5").value But this does not work

Code:

TempFileName = Format(Now, "mm-dd-yyyy") & "Submission of " & "Panic" & sheet1.range("a5").value


My code for sendin e-mail

Code:

Sub Mail_ActiveSheet()
'Working in 2000-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 OutApp As Object
    Dim OutMail As Object
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
 
    'Copy the sheet to a new workbook
    Sheet2.Copy
    Set Destwb = ActiveWorkbook
 
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 2000-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 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 = Format(Now, "mm-dd-yyyy") & "Submission of " & "Panic"
 
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
 
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = "panic@home.com"
            .CC = ""
            .BCC = ""
            .Subject = TempFileName
            .Body = "Weekly Submission"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send   'or use .Display
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    Set OutMail = Nothing
    Set OutApp = Nothing
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub


can anyone help me

Thanks

Panic


Not able to execute this macro.



Option Explicit
Sub Mail_ActiveSheet()
' Works in Excel 97 through Excel 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 OutApp As Object
Dim OutMail As Object
Dim subject As String
Dim body As String
Dim toaddr As String
Dim indx As Integer

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

subject = Trim(Worksheets("MSG").Range("B1"))
body = Trim(Worksheets("MSG").Range("B2"))

For indx = 1 To 300
If Trim(Worksheets("MSG").Range("B" & indx)) = "" Then
toaddr = Trim(Worksheets("MSG").Range("B3"))



Set Sourcewb = ActiveWorkbook
' Using ActiveSheet.Copy creates a new workbook with
' the sheet and the file format is the same as the
' original workbook.
' Copy the worksheet to a new workbook.
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

' Determine the Excel version and file extension/format.
With Destwb
If Val(Application.Version) < 12 Then
' You are using Excel 97-2003.
FileExtStr = ".xls": FileFormatNum = -4143
Else
' You are using Excel 2007.
' When you use ActiveSheet.Copy to create a workbook,
' you are prompted with a security dialog. If you click No
' in the dialog, then the name of Sourcewb is the same
' as Destwb and you exit the subroutine. You only see this
' dialog when you attempt to copy a worksheet from an .xlsm file with macros disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is No in the security dialog."
Exit Sub
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:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
' 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 If
End With

' Change all cells in the worksheet to values, if desired.
'' With Destwb.Sheets(1).UsedRange
'' .Cells.Copy
'' .Cells.PasteSpecial xlPasteValues
'' .Cells(1).Select
'' End With
''Application.CutCopyMode = False

'Save the new workbook and then mail it.
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

'With Destwb
' .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
' On Error Resume Next
' For I = 1 To 3
' .SendMail "someone@somewhere.com", _
' "This is the Subject line"
' If Err.Number = 0 Then Exit For
'Next I
' On Error GoTo 0
'.Close SaveChanges:=False
'End With

' Delete the file you just sent.
Kill TempFilePath & TempFileName & FileExtStr

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

End If
End Sub


I have the following code as part of a macro which sets up an e-mail with a temporary .xls file attached. What i want to do is amend/add to the code something that copies another worksheet (called "epos") in my workbook and also adds this as a seperate csv attachment called "epos".

Code:

'E-MAILS SHEET
      Dim ans As String
ans = MsgBox("e-mail prices to studio/teletext?", vbYesNo + vbQuestion, "E-mail?")
If ans = vbYes Then

    Sheets("Selection").Select

              
    'Working in 2000-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 OutApp As Object
    Dim OutMail As Object

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

    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
  

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 2000-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 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 = "Golf Matches"

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = ""
            .CC = ""
            .BCC = ""
            .Subject = "Golf Matches" & "  ***"
            .Body = ""
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

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

    Set OutMail = Nothing
    Set OutApp = Nothing

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

    Windows("Golf Matches Upload.xls").Activate
    Sheets("Input Sheet").Select
    Range("M3").Select
    
    Else

    Sheets("Input Sheet").Select
    Range("M3").Select
    
End If


Any help much appreciated.

Thanks,
Adam.