Macro para copiar datos de una hoja a otro y guardar el nuevo libro con el nombre de una celda y la ruta en excel

Tengo la siguiente macro:

Sub ExportarCompleto()
Dim UltimaFila As Long
Dim dir As FileSystemObject
Set dir = New FileSystemObject
Dim Archivo As String
Dim Linea As String
Dim Origen As Long
Archivo = Range("D_DISCO") & ":\CARGA MASIVA PLAME"
If dir.FolderExists(Archivo) = False Then
dir.CreateFolder (Archivo)
End If
Archivo = Range("D_DISCO") & ":\CARGA MASIVA PLAME\" + CStr(Range("RUC")) + "\"
If dir.FolderExists(Archivo) = False Then
dir.CreateFolder (Archivo)
End If
Archivo = Range("D_DISCO") & ":\CARGA MASIVA PLAME\" + CStr(Range("RUC")) + "\" + "PLAME" + "\"
If dir.FolderExists(Archivo) = False Then
dir.CreateFolder (Archivo)
End If
Archivo = Range("D_DISCO") & ":\CARGA MASIVA PLAME\" + CStr(Range("RUC")) + "\" + "PLAME" + "\" + CStr(Range("PERIODO")) + "\"
If dir.FolderExists(Archivo) = False Then
MkDir (Range("D_DISCO") & ":\CARGA MASIVA PLAME\" + CStr(Range("RUC")) + "\" + "PLAME" + "\" + CStr(Range("PERIODO")))
End If
Archivo = Range("D_DISCO") & ":\CARGA MASIVA PLAME\" + CStr(Range("RUC")) + "\" + "PLAME" + "\" + CStr(Range("PERIODO")) + _
"\" + CStr(Range("D_NOMBRE")) + ".rem"
Origen = FreeFile

If dir.FileExists(Archivo) = True Then
Kill Archivo
End If
UltimaFila = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To UltimaFila
Linea = CStr(Cells(i, 1)) '+ "|"
Open Archivo For Append As #Origen
Print #Origen, Linea
Close #Origen
Next
End Sub

Esta macro me copia información de una hoja a una nueva hoja y lo guarda en la ruta indicado pero en archivo Plano, pero lo que requiero es que lo guarde en excel y desde la celda B2 hasta la celda G2 pero solo hasta la fila que tenga información.