Este fórum está sendo desativado

[cbluciano21]

Pessoal, dá uma força para resolver esse problema

Eu fiz o código abaixo para copiar os dados/formato do arquivo "Pricing_Corporativo - Prop2021-xxxx-v1_Customer" e criar um novo arquivo para colar os dados/formato. Beleza! eu consegui fazer isso, porém, eu preciso que o novo arquivo seja salvo com o nome da seguinte forma "LPU_(data Windows)_prop2021-xxxx-v1_Customer" e que esteja no diretório do arquivo de origem (Pricing_Corporativo[...]_Customer), mas é neste que estou me perdendo, pois o novo arquivo perde a referência do diretório. Anexei a imagem da etapa que quero eliminar, ou seja, quero que seja feito automaticamente.

Obs.: onde esta "xxxx" é alterado para número conforme cada usuário utiliza o arquivo, assim como o "Customer" é alterado para o nome do cliente em questão.

Abaixo o código e onde esta grifado o paliativo que estou usando atualmente, mas que desejo deixar "automatizado" 

Option Explicit

Sub btExecuta_Click()

Dim WP      As Workbook     'Pasta de trabalho atual
Dim WS      As New Workbook 'Nova Pasta de Trabalho
Dim WPSheet As Worksheet    'Planilha Atual
Dim rngWp   As Range        'Região com dados da plan atual
Dim X As Byte
Dim Y As Long
Dim Z As Integer

Set WP = ActiveWorkbook
Set WPSheet = WP.Sheets("Pricing")

Range(Cells(5, 5), Cells(2000, 31)).Copy 'Copia todas as celulas utilizadas. VERIFICAR COMO DELIMITAR A REGIÃO A SER COPIADA

Set WS = Workbooks.Add 'Adiciona uma nova workbook

WS.Sheets(1).Select

ActiveCell.PasteSpecial Paste:=xlPasteValues                        'Cola os valores
ActiveCell.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone    'Cola o formato

Range(Cells(1, 1), Cells(4, 6)).Clear 'Limpa os dados referente à margem
Range(Cells(1, 5), Cells(2000, 5)).Delete 'Deleta os dados referente ao PV unit sem impostos
Range(Cells(1, 6), Cells(2000, 6)).Delete 'Deleta os dados referente ao PV unit sem impostos

WS.Sheets(1).Name = WPSheet.Name

ActiveWindow.DisplayGridlines = False 'Retira as linhas de grade

Worksheets("Pricing").Range("A1:X2000").Columns.AutoFit

Worksheets("Pricing").Range("A1").Select

Application.DisplayAlerts = False

ThisWorkbook.SaveAs 'indica a pasta para salvar e é necessário digitar o nome
WS.Close savechanges:=True

Application.DisplayAlerts = True

WP.Activate
WP.Sheets(33).Select

WPSheet.Range("G7").Select

MsgBox "Anexo Salvo", vbOKOnly

End Sub

[AfonsoMira]

Boas experimente algo deste género:

Código: Selecionar todos

Sub btExecuta_Click()

Dim WP      As Workbook     'Pasta de trabalho atual
Dim WS      As New Workbook 'Nova Pasta de Trabalho
Dim WPSheet As Worksheet    'Planilha Atual
Dim rngWp   As Range        'Região com dados da plan atual
Dim X As Byte
Dim Y As Long
Dim Z As Integer
Dim caminho As String

Set WP = ActiveWorkbook
Set WPSheet = WP.Sheets("Pricing")
caminho = WP.Path

Range(Cells(5, 5), Cells(2000, 31)).Copy 'Copia todas as celulas utilizadas. VERIFICAR COMO DELIMITAR A REGIÃO A SER COPIADA

Set WS = Workbooks.Add 'Adiciona uma nova workbook

WS.Sheets(1).Select

ActiveCell.PasteSpecial Paste:=xlPasteValues                        'Cola os valores
ActiveCell.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone    'Cola o formato

Range(Cells(1, 1), Cells(4, 6)).Clear 'Limpa os dados referente à margem
Range(Cells(1, 5), Cells(2000, 5)).Delete 'Deleta os dados referente ao PV unit sem impostos
Range(Cells(1, 6), Cells(2000, 6)).Delete 'Deleta os dados referente ao PV unit sem impostos

WS.Sheets(1).Name = WPSheet.Name

ActiveWindow.DisplayGridlines = False 'Retira as linhas de grade

Worksheets("Pricing").Range("A1:X2000").Columns.AutoFit

Worksheets("Pricing").Range("A1").Select

Application.DisplayAlerts = False

WS.Close True, caminho & "\Pricing_Corporativo - Prop2021-xxxx-v1_Customer.xlsx"

Application.DisplayAlerts = True

WP.Activate
WP.Sheets(33).Select

WPSheet.Range("G7").Select

MsgBox "Anexo Salvo", vbOKOnly

End 

Sub