Este fórum está sendo desativado

[EdersonFarias]

Olá caros amigos, alguém pode me ajudar urgente com isso ???

Criei uma macro (abaixo), onde:

1º - Através da informação de uma célula, CRIO O SUB-DIRETÓRIO com o nome do dado que estiver na célula --- OK, Funcionando!!

2º - Através da informação de outra célula, SALVO O ARQUIVO com o nome do dado que estiver em outra célula --- OK, Funcionando!!

Agora não sei como salvar ou mover esse arquivo novo (onde acabei de dar o nome) para esse diretório (que não existia)..

Vejam a macro:

' Criar o diretório com o nome da célula

Dim PASTA As Range
Dim maxRows, maxCols, r, c As Integer
Range("B10").Select
Set PASTA = Selection
maxRows = PASTA.Rows.Count
maxCols = PASTA.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & PASTA(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & PASTA(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c


' Salvar o arquivo com o nome da célula

Dim Nome As String
Nome = Worksheets(1).Range("q3")

ActiveWorkbook.SaveAs Filename:="C:\Users\Eder\Desktop\Teste\" & Range("q3").Value & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

[Reinaldo]

Altere o caminho no seu SaveAs:

Código: Selecionar todos

ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\" & PASTA(r, c) & "\" & Range("q3").Value & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Onde Pasta(r,c) corresponde ao nome do subdiretoriocriado

Ou veja sobre copias ou mover arquivos/diretorios em https://www.rondebruin.nl/win/s3/win026.htm

[EdersonFarias]

Não está dando certo... e não sei onde estou errando...

veja como ficou tudo:

Sub Salvar1()

' Criar nome da planilha

Range("Q1").Select
Selection.Copy
Range("Q3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("Q3").Select

' Criar o SUB DIRETÓRIO

Dim Pasta As Range
Dim maxRows, maxCols, r, c As Integer
Set Pasta = Selection
maxRows = Pasta.Rows.Count
maxCols = Pasta.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Range("q3").Value & Pasta(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Range("q3").Value & Pasta(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c

' Salvar no SUB DIRETÓRIO

Dim Nome As String
Nome = Worksheets(1).Range("q3")
ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\" & Pasta(r, c) & "\" & Range("q3").Value & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Sheets("Cad-Cliente1").Select
Range("M4").Select

' Deleta Tecla para o usuário não fazer denovo
ActiveSheet.Shapes.Range(Array("Botão 213")).Select
Selection.Delete

' SeguIR para outra planilha
Sheets("Cad-Cliente2").Select
Range("E3:M3").Select

End Sub

[Reinaldo]

Como disse Pasta(r,c) deve se referir ao nome do diretorio criado.
Como sua rotina e feito um loop (não sei porque e nem onde) --> For c=1 toMaxColum é preciso "capturar" esse nome na criação ou salvar o arquivo logo após a criação desse subdiretorio, e não depois de encerrar o loopr

[EdersonFarias]

Mudei e tirei o loop... ele cria o diretório... e se eu tirar essa função ele salva o arquivo com nome correto (no caso a pasta e o arquivo, quero com o mesmo nome).. MAS QUANDO TENTO USAR AS DUAS FUNÇÕES (CRIAR O DIRETÓRIO E DEPOIS SALVAR O ARQUIVO DENTRO DESSE DIRETÓRIO) não dá certo...

Veja como deixei mais limpo a instrução:


Sub Salvar1()

' Criar nome da planilha

Range("Q1").Select
Selection.Copy
Range("Q3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("Q3").Select

' Criar o diretório

Dim Pasta As Range
Dim maxRows, maxCols, r, c As Integer
Set Pasta = Selection
maxRows = Pasta.Rows.Count
maxCols = Pasta.Columns.Count
MkDir (ActiveWorkbook.Path & "\" & Range("q3").Value & Pasta(r, c))

' Salvar o arquivo com o nome novo no diretório novo

Dim Nome As String
Nome = Worksheets(1).Range("q3")
ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & “\" & Pasta(r, c) & "\" & Range("q3").Value & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

End Sub

[osvaldomp]

Experimente:

Código: Selecionar todos

Sub SalvaArquivo()
 On Error Resume Next
 MkDir (ActiveWorkbook.Path & "\" & Range("Q1").Value)
 On Error GoTo 0
 ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & Range("Q1").Value & "\" & Range("Q1").Value & ".xls"
End Sub