VBA copy Values exclude 1 column and formula

[bombergirl61]

Good afternoon

I have a spreadsheet that has a lot of formulas. I copy the spreadsheet and send via out look. At present I copy the used range and values.

I actually need to copy all columns accept N as a value, N needs to keep its formula in the sheet that is attached to the email.

Below is what I current have, I think i need to somewhere change the range to A:m,O:Z. I need to ensure when the person receives the spreadsheet and enters data that column N calculates

Sub Z_Mail_TUBE_PIPE_BUYTEST()
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim DueDate As String
DueDate = Format(ThisWorkbook.Sheets("National").Range("ad1").Value, "dd-mmm-yyyy")

TempFilePath = Environ$("temp") & "\"

If Val(Application.Version) < 12 Then

FileExtStr = ".xls": FileFormatNum = -4143
Else

FileExtStr = ".xlsm": FileFormatNum = 52
End If

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

Set OutApp = CreateObject("Outlook.Application")

For Each sh In ThisWorkbook.Worksheets
If sh.Range("A1").Value Like " *?*@?*.?*" Then

sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ActiveSheet
.UsedRange.Value = UsedRange.Value
.Name = sh.Name & Format(Now, "dd-mmm-yy h-mm-ss")
.Move
End With
Set wb = ActiveWorkbook

TempFileName = sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")


Set OutMail = OutApp.CreateItem(0)

With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

On Error Resume Next
With OutMail
.To = sh.Range("A1").Value
.CC = ""
.BCC = ""
.Subject = "TUBE AND PIPE REQUIREMENTS"
.Body = "Hello" & vbNewLine & "Tube and Pipe Overseas purchase " & vbNewLine & "Please complete Column M with your requirements," & vbNewLine & "Return by " & DueDate & vbNewLine & vbNewLine & "Cheers" & vbNewLine & "Cheryl "
.Attachments.Add wb.FullName

.Display
End With
On Error GoTo 0

.Close savechanges:=False
End With

Set OutMail = Nothing

Kill TempFilePath & TempFileName & FileExtStr

End If
Next sh

Set OutApp = Nothing

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

 

[Anthony47]

Try replacing the line .UsedRange.Value = UsedRange.Value with

    Application.Intersect(.UsedRange, .Range("A:M")).Value = Application.Intersect(.UsedRange, .Range("A:M")).Value
    Application.Intersect(.UsedRange, .Range("O:ZZ")).Value = Application.Intersect(.UsedRange, .Range("O:ZZ")).Value

This assumes your worksheet has less than 700 columns

 

[bombergirl61]

Try replacing the line .UsedRange.Value = UsedRange.Value with

    Application.Intersect(.UsedRange, .Range("A:M")).Value = Application.Intersect(.UsedRange, .Range("A:M")).Value
    Application.Intersect(.UsedRange, .Range("O:ZZ")).Value = Application.Intersect(.UsedRange, .Range("O:ZZ")).Value

This assumes your worksheet has less than 700 columns

Thank you so very much works like a charm. appreciate your help.

 

[bombergirl61]

Thank you so very much works like a charm. appreciate your help.

03/02/2025
HI

Any tips why this code would just stop working. I use debug and it halts at

If sh.Range("A1").Value Like "?*@?*.?*" Then

Whole code below

Sub Z_Mail_SHEET_BUY_ALUMINIUM_all()
    Dim sh As Worksheet
    Dim wb As Workbook
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim DueDate As String
    DueDate = Format(ThisWorkbook.Sheets("National").Range("ad1").Value, "dd-mmm-yyyy")
   
    TempFilePath = Environ$("temp") & "\"

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsm": FileFormatNum = 52
    End If

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

    Set OutApp = CreateObject("Outlook.Application")

    For Each sh In ThisWorkbook.Worksheets
        If sh.Range("A1").Value Like "?*@?*.?*" Then
       
  sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    With ActiveSheet
Application.Intersect(.UsedRange, .Range("A:l")).Value = Application.Intersect(.UsedRange, .Range("A:l")).Value
    Application.Intersect(.UsedRange, .Range("n:Z")).Value = Application.Intersect(.UsedRange, .Range("n:Z")).Value

      .Name = sh.Name & Format(Now, "dd-mmm-yy h-mm-ss")
      .Move
    End With

            Set wb = ActiveWorkbook

            TempFileName = sh.Name & " of " _
                         & ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")


            Set OutMail = OutApp.CreateItem(0)

            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

                On Error Resume Next
                With OutMail
                    .to = sh.Range("A1").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = "ALUMINIUM REQUIREMENTS"
                    .Body = Format(ThisWorkbook.Sheets("National").Range("ae1").Value, "VB")
                    .Attachments.Add wb.FullName
                    'You can add other files also like this
                    '.Attachments.Add ("C:\test.txt")
                    .Display 'disable display and enable send to send automaticall
                End With
                On Error GoTo 0

                .Close savechanges:=False
            End With
           
            Set OutMail = Nothing

            Kill TempFilePath & TempFileName & FileExtStr

        End If
    Next sh

    Set OutApp = Nothing

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

 

[Peter_SSs]

@bombergirl61
When posting vba code in the forum, please use the available code tags. It makes your code much easier to read/debug & copy. My signature block at the bottom of this post has more details. I have added the tags for you this time.

 

[Peter_SSs]

@bombergirl61
One more thing. Please do not mark a post as the answer to your question unless it is that. I have removed the 'Mark as solution' from post #5.

 

[Anthony47]

Any tips why this code would just stop working. I use debug and it halts at
If sh.Range("A1").Value Like "?*@?*.?*" Then

@bombergirl61
Maybe you already solved the problem, but my best guess is that Range("A1") of a sheet displays an error condition.
If this is the case, than you might add an additional If /End If as follows:

    For Each Sh In ThisWorkbook.Worksheets
        If Not IsError(Sh.Range("A1").Value) Then               '<<< Added If
            If Sh.Range("A1").Value Like "?*@?*.?*" Then
                'your code
                'your code

                Kill TempFilePath & TempFileName & FileExtStr
            End If
        End If                                              '<<< Added End If
    Next Sh