Bom dia a todos , vou usar este código na planilha anexa ,
Sub Gerar_Programação()
Dim Nome, NomeCopia As String
Dim UltLinha As Long
Desprot
Rows("99:99").Select
Selection.AutoFilter
ActiveWindow.ScrollColumn = 1
ActiveSheet.Range("$A$99:$A$5000").AutoFilter Field:=3, Criteria1:="S"
UltLinha = ActiveSheet.Range("C65000").End(xlUp).Row + 1
Cid = Range("A100").Value
Alim = Range("B100").Value
Disposit = Range("F68").Value
Reexibir_Para_Edição
ActiveSheet.Range("D100:G" & UltLinha & " , I100:I" & UltLinha & ",T100:T" & UltLinha & ",W100:W" & _
UltLinha & ",Z100:Z" & UltLinha & ",AB100:AD" & UltLinha & ",AF100:AF" & UltLinha & ",AI100:AI" & _
UltLinha & ",AL100:AL" & UltLinha & ",AN100:AN" & UltLinha & ",AP100:AQ" & UltLinha).Select
Selection.Copy
Nome = ActiveWorkbook.Name
NomeCopia = "Executar " & Left(ActiveSheet.Name, Len(ActiveSheet.Name))
Workbooks.Add
Range("A3").Select
ActiveSheet.Paste
somat = ActiveSheet.Range("E65000").End(xlUp).Row + 1
Range("A1").Value = "Cidade:"
Range("B1").Value = Cid
Range("D1").Value = "Dispositivo_Aliment.:"
Range("E1").Value = Disposit & "_" & Alim
Range("K1").Value = "Executor/Data:"
Range("A2").Value = "Ponto 1"
Range("A2").Value = "Ponto 1"
Range("B2").Value = "Ponto 2"
Range("C2").Value = "Coord. do Ponto1"
Range("D2").Value = "Coord. do Ponto2"
Range("E2").Value = "US's"
Range("F2").Value = "Faixa 10M"
Range("G2").Value = "Faixa 15M"
Range("H2").Value = "Abertura "
Range("I2").Value = "Bambu M²"
Range("J2").Value = "Aceiro"
Range("K2").Value = "Cerca Viva"
Range("L2").Value = "Cipó"
Range("M2").Value = "Podar Arv."
Range("N2").Value = "Cortar Arv."
Range("O2").Value = "Arv. Silvic."
Range("P2").Value = "Arv. Silvic. > Q 5"
Range("Q2").Value = "Abert. Acesso"
Range("R2").Value = "Observação"
Range("D" & somat).Value = "Total em US's"
Mesclar
AjustarImpr
AjustaBordas
Ajustar
Rows("1:1").RowHeight = 33
Cells(somat, 5).Value = Application.WorksheetFunction.Sum(Range("E3:E" & somat))
Range("E" & somat & ":" & "H" & somat).Select
Selection.Merge
Range("E" & somat).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
ActiveWorkbook.SaveAs NomeCopia
Range("A3").Select
Windows(Nome).Activate
Reexibir_Para_Edição
Desprot
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("A100").Select
Prot
End Sub
Porem na linha ; Workbooks.Add e ActiveWorkbook.SaveAs NomeCopia
Precisava que fosse o seguinte;
1- A "pasta de trabalho gerada" fosse com somente uma planilha e com o nome da planilha "original" e não Plan1 , Plan2 e Plan3 como está sendo.
2- O salvamento É em local não determinado(não sei nem qual o critério e onde esta sendo salvo). Existe como determinar no código que seja Verificado em C: se existe uma Pasta de Arquivos com o nome de Controle de Execução de Faixa ; caso haja , salvar dentro desta pasta de arquivos a "pasta de trabalho gerada" , se não houver a pasta de arquivos Controle de Execução de Faixa , então tomar a seguinte providencia Criar,Novo,Pasta de Arquivos e nomear com Controle de Execução de Faixa e então proceder o salvamento.
Para entender , no anexo; clicar em Gerar_Programação
Por hora muito obrigado a todos.
Postado : 11/03/2013 11:28 am