Copy to a new worksheet with INDIRECT functions-Please help!

needhelpvba

New Member
Joined
Jun 16, 2013
Messages
7
Hi guys, I REALLY need an urgent help on this! My goal is to create pdf files of the sheets whose names are in B7 and send them to people in D7-F7. How the code works is that it will create a copy of the sheet(s) and create pdf files out of that. Everything works fine except that the part that has the INDIRECT formulas when copied to a new worksheet (and created a pdf) will all have #VALUES. How can I fix that? I'm required to use these formulas so I won't be able to change them, just the code. I highlighted the part that I may need to change. Please help!!
Rich (BB code):
Option Explicit
Private Sub RDB_Outlook_Click()
    Dim StringTo As String, StringCC As String, StringBCC As String
    Dim ShArr() As String, FArr() As String, strDate As String
    Dim myCell As Range, cell As Range, rng As Range, Fname As String, Fname2 As String
    Dim wb As Workbook, sh As Worksheet
    Dim DefPath As String
    Dim olApp As Object
    Dim olMail As Object
    Dim FileExtStr As String
    Dim ws As Worksheet
    
    Dim ToArray As Variant
    Dim CCArray As Variant
    Dim BCCArray As Variant
    Dim StringFileNames As String
    Dim StringSheetNames As String
    Dim FileNamesArray As Variant
    Dim SheetNamesArray As Variant
    Dim I As Long, S As Long, F As Long
    Dim WrongData As Boolean
    If Len(ThisWorkbook.Path) = 0 Then
        MsgBox "This macro will only work if the file is Saved once", 48, "RDBMailPDFOutlook"
        Exit Sub
    End If
    If Me.ProtectContents = True Or ActiveWindow.SelectedSheets.Count > 1 Then
        MsgBox "This macro will not work if the RDBMailOutlook worksheet is " & _
               "protected or if you have more then sheet selected(grouped)", 48, "RDBMailPDFOutlook"
        Exit Sub
    End If
    'Set folder where we save the temporary files
    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
    'Set reference to Outlook and turn of ScreenUpdating and Events
    Set olApp = CreateObject("Outlook.Application")
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Set cells with Red interior color to no fill(cells with wrong data)
    Range("A6").ListObject.DataBodyRange.Interior.Pattern = xlNone
    'Set rng to the first column of the table
    Set rng = Me.Range("A6").ListObject.ListColumns(1).Range
    For Each myCell In rng
        'Create mail if "Yes " in column A
        If LCase(myCell.Value) = "yes" Then
            StringTo = "": StringCC = "": StringBCC = ""
            S = 0: F = 0
            Erase ShArr: Erase FArr
            'Set Error Boolean to False
            WrongData = False
            'Check if there are Sheet names in column B
            'If B is empty S = 0 so you not want to send a sheet or sheets as pdf
            If Trim(Me.Cells(myCell.Row, "B").Value) = "" Then S = 0
            'If there are sheet names in the B column S is the number of sheets it add to the Array
            If LCase(Trim(Me.Cells(myCell.Row, "B").Value)) <> "workbook" Then
                StringSheetNames = Me.Cells(myCell.Row, "B").Value
                SheetNamesArray = Split(StringSheetNames, Chr(10), -1)
                For I = LBound(SheetNamesArray) To UBound(SheetNamesArray)
                    On Error Resume Next
                    If SheetNamesArray(I) <> "" Then
                        If SheetExists(CStr(SheetNamesArray(I))) = False Then
                            Me.Cells(myCell.Row, "B").Interior.ColorIndex = 3
                            WrongData = True
                        Else
                            S = S + 1
                            ReDim Preserve ShArr(1 To S)
                            ShArr(S) = SheetNamesArray(I)
                        End If
                    End If
                    On Error GoTo 0
                Next I
            Else
                'If you only enter "workbook" in colomn B to mail the whole workbook S = -1
                S = -1
            End If
            'Check to Mail addresses in column D
            If Trim(Me.Cells(myCell.Row, "D").Value) <> "" Then
                StringTo = Me.Cells(myCell.Row, "D").Value
                ToArray = Split(StringTo, Chr(10), -1)
                StringTo = ""
                For I = LBound(ToArray) To UBound(ToArray)
                    If ToArray(I) Like "?*@?*.?*" Then
                        StringTo = StringTo & ";" & ToArray(I)
                    End If
                Next I
            End If
            'Check to Mail addresses in column E
            If Trim(Me.Cells(myCell.Row, "E").Value) <> "" Then
                StringCC = Me.Cells(myCell.Row, "E").Value
                CCArray = Split(StringCC, Chr(10), -1)
                StringCC = ""
                For I = LBound(CCArray) To UBound(CCArray)
                    If CCArray(I) Like "?*@?*.?*" Then
                        StringCC = StringCC & ";" & CCArray(I)
                    End If
                Next I
            End If
            'Check to Mail addresses in column F
            If Trim(Me.Cells(myCell.Row, "F").Value) <> "" Then
                StringBCC = Me.Cells(myCell.Row, "F").Value
                BCCArray = Split(StringBCC, Chr(10), -1)
                StringBCC = ""
                For I = LBound(BCCArray) To UBound(BCCArray)
                    If BCCArray(I) Like "?*@?*.?*" Then
                        StringBCC = StringBCC & ";" & BCCArray(I)
                    End If
                Next I
            End If
            If StringTo = "" And StringCC = "" And StringBCC = "" Then
                Me.Cells(myCell.Row, "D").Resize(, 3).Interior.ColorIndex = 3
                WrongData = True
            End If
            'Check the other files that you want to attach in column H
            If Trim(Me.Cells(myCell.Row, "H").Value) <> "" Then
                StringFileNames = Me.Cells(myCell.Row, "H").Value
                FileNamesArray = Split(StringFileNames, Chr(10), -1)
                For I = LBound(FileNamesArray) To UBound(FileNamesArray)
                    On Error Resume Next
                    If FileNamesArray(I) <> "" Then
                        If Dir(FileNamesArray(I)) <> "" Then
                            If Err.Number = 0 Then
                                F = F + 1
                                ReDim Preserve FArr(1 To F)
                                FArr(F) = FileNamesArray(I)
                            Else
                                Err.Clear
                                Me.Cells(myCell.Row, "H").Interior.ColorIndex = 3
                                WrongData = True
                            End If
                        Else
                            Me.Cells(myCell.Row, "H").Interior.ColorIndex = 3
                            WrongData = True
                        End If
                    End If
                    On Error GoTo 0
                Next I
            End If
            'Not create the mail if there are Errors in the row (wrong sheet or file names or no mail addresses)
            If WrongData = True Then GoTo MailNot

            'Create PDF and Mail
            'Create Date/time string for the file name
            strDate = Format(Now, "dd-mmm-yyyy hh-mm-ss")
            'Copy the sheet(s)to a new workbook
         
              If S > 0 Then
                On Error GoTo 0
                ThisWorkbook.Sheets(ShArr).Copy
                For Each ws In ActiveWorkbook.Sheets
                With ws.Cells
                    .Value = .Value
                    .Hyperlinks.Delete
                End With
                Next ws
      
            End If  
            'You enter only "workbook" in colomn B to mail the whole workbook
            
            'Use SaveCopyAs to make a copy of the workbook
            If S = -1 Then
                FileExtStr = "." & LCase(Right(ThisWorkbook.Name, _
                                               Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, ".", , 1)))
                Fname2 = DefPath & "TempFile " & FileExtStr
                ThisWorkbook.SaveCopyAs Fname2
                Me.Activate
                Set wb = Workbooks.Open(Fname2)
                Application.DisplayAlerts = False
                wb.Sheets(Me.Name).Delete
                Application.DisplayAlerts = True
                If wb.Sheets(1).Visible = xlSheetVisible Then wb.Sheets(1).Select
            End If
        

            'Now we Publish to PDF
            If S <> 0 Then
                Fname = DefPath & Trim(Me.Cells(myCell.Row, "C").Value) & _
                      ".pdf"
                Fname = Replace(Fname, Chr(10), " & ")
                On Error Resume Next
                wb.ExportAsFixedFormat _
                        Type:=xlTypePDF, _
                        FileName:=Fname, _
                        Quality:=xlQualityStandard, _
                        IncludeDocProperties:=True, _
                        IgnorePrintAreas:=False, _
                        OpenAfterPublish:=False
                On Error GoTo 0
                wb.Close False
                Set wb = Nothing
            End If
            On Error Resume Next
            Set olMail = olApp.CreateItem(0)
            With olMail
                .To = StringTo
                .CC = StringCC
                .BCC = StringBCC
                .Subject = Me.Cells(myCell.Row, "G").Value
                .Body = Me.Cells(myCell.Row, "I").Value
                If S <> 0 Then .Attachments.Add Fname
                If F > 0 Then
                    For I = LBound(FArr) To UBound(FArr)
                        .Attachments.Add FArr(I)
                    Next I
                End If
                'Set Importance  0 = Low, 2 = High, 1 = Normal
                If LCase(Me.Cells(myCell.Row, "J").Value) = "yes" Then
                    .Importance = 2
                End If
                'Display the mail or send it directly, see cell C3
                If LCase(Me.Range("C3").Value) = "yes" Then
                    .Display
                Else
                    .Send
                End If

            End With
            If S = -1 Then Kill Fname2
            Kill Fname
            On Error GoTo 0
            Set olMail = Nothing
        End If
MailNot:
    Next myCell
    If LCase(Me.Range("C3").Value) = "no" Then
        MsgBox "The macro is ready and if correct the mail or mails are created." & vbNewLine & _
               "If you see Red cells in the table then the information in the cells is " & vbNewLine & _
               "not correct. For example there is a sheet or filename that not exist." & vbNewLine & _
               "Note: It will not create a Mail of the information in a row with a " & vbNewLine & _
               "Red cell or cells.", 48, "RDBMailPDFOutlook"
    End If

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    Set olApp = Nothing
End Sub

Function SheetExists(wksName As String) As Boolean
    On Error Resume Next
    SheetExists = CBool(Len(ThisWorkbook.Sheets(wksName).Name) > 0)
    On Error GoTo 0
End Function
Private Sub BrowseAddFiles_Click()
    Dim Fname As Variant
    Dim fnum As Long
    If ActiveCell.Column = 8 And ActiveCell.Row > 6 Then
        Fname = Application.GetOpenFilename(filefilter:="All Files (*.*), *.*", _
                                            MultiSelect:=True)
        If IsArray(Fname) Then
            For fnum = LBound(Fname) To UBound(Fname)
                If fnum = 1 And ActiveCell.Value = "" Then
                    ActiveCell.Value = ActiveCell.Value & Fname(fnum)
                Else
                    If Right(ActiveCell, 1) = Chr(10) Then
                        ActiveCell.Value = ActiveCell.Value & Fname(fnum)
                    Else
                        ActiveCell.Value = ActiveCell.Value & Chr(10) & Fname(fnum)
                    End If
                End If
            Next fnum
            With Me.Range("J1").EntireColumn
                .ColumnWidth = 255
                .AutoFit
            End With
            With Me.Rows
                .AutoFit
            End With
        End If
    Else
        MsgBox "Select a cell in the ""Attach other files"" column", 48, "RDBMailPDFOutlook"
    End If
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 3 And Target.Column < 7 And Target.Row > 6 Then
        With Range(Target.Address)
            .Hyperlinks.Delete
        End With
    End If
End Sub
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December

Forum statistics

Threads
1,215,692
Messages
6,126,226
Members
449,303
Latest member
grantrob

We've detected that you are using an adblocker.

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

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

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

Disable uBlock

Follow these easy steps to disable uBlock

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