Para los expertos que pueden ayudar con esta macro

Expertos buenos día tengo el siguiente código, pero no puedo lograr que el asusto cambie según el el valor de una celda, agradacere mucho la ayuda de ustedes en este tema aquí les dejo el código:

Public Sub copiahoja()
Sheets("hoja2").Copy
Dim dia As String
Dim tim As String
Dim nom As String
Dim ext As String
Dim Path As String
dia = Format(Date, "dd-mm-yyyy ")
tim = Format(Time(), " hh-mm")
ext = ".xls"
nom = nom + " " + dia + tim & ".xls"
MsgBox "este es el nombnre del archivo: solicitud de remesas"" " & nom
Path = "d:\solicitud de remesas" & nom
ActiveWorkbook.SaveAs Filename:=Path, FileFormat:=xlNormal
ActiveWorkbook.Close
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Range("h7").Value
.CC = " "
.BCC = ""
.Subject = "Solicitud de Remesas" + Chr(13) + Str(Date) + Range("c6")
.Body = "Buenas Tardes:" + Chr(13) + Chr(13) + "Adjunto envío a usted informe de la referencia" + Chr(13) + Chr(13) + "Saludos."
.attachments.Add "D:\solicitud de remesas" & nom
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
ActiveWindow.Close
Application.Quit
End Sub