Este fórum está sendo desativado

Depois de 9 anos, este fórum será desativado. Mas calma.... estamos migrando para uma comunidade no DISCORD. Junte-se a nós.

ENTRAR PARA DISCORD

Tópicos relacionados a códigos VBA, gravação de macros, etc.
  • Avatar do usuário
#35836
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
Avatar do usuário
Por Reinaldo
Avatar
#35841
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
#35842
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
Avatar do usuário
Por Reinaldo
Avatar
#35843
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
#35844
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
#35848
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
long long title how many chars? lets see 123 ok more? yes 60

We have created lots of YouTube videos just so you can achieve [...]

Another post test yes yes yes or no, maybe ni? :-/

The best flat phpBB theme around. Period. Fine craftmanship and [...]

Do you need a super MOD? Well here it is. chew on this

All you need is right here. Content tag, SEO, listing, Pizza and spaghetti [...]

Lasagna on me this time ok? I got plenty of cash

this should be fantastic. but what about links,images, bbcodes etc etc? [...]

Estamos migrando para uma comunidade no Discord