Wendell Menezes

Coloque a fórmula abaixo na célula K15 e arraste até a N15
=SE(E($F$11<>"NA";ÉERROS(PROCH($E$11;$J$15:J15;1;0)));$E$11;SE(E($F$12<>"NA";ÉERROS(PROCH($E$12;$J$15:J15;1;0)));$E$12;SE(E($L$8<>"NA";ÉERROS(PROCH($J$8;$J$15:J15;1;0)));$J$8;SE(E($L$9<>"NA";ÉERROS(PROCH($J$9;$J$15:J15;1;0)));$J$9;SE(E($L$10<>"NA";ÉERROS(PROCH($J$10;$J$15:J15;1;0)));$J$10;SE(E($L$11<>"NA";ÉERROS(PROCH($J$11;$J$15:J15;1;0)));$J$11;""))))))

Sub Hyperlinks()
Dim r As Long
For r = 5 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(r, 1).Activate
ActiveSheet.Hyperlinks.Add Selection, "", "'ART (" & IIf(Len(Cells(r, 1)) = 1, "0", "") & Cells(r, 1) & ")'!A1"
Next
End Sub

Olá,
 
Coloque a fórmula abaixo na célula B2 e arraste até B3:
=SOMARPRODUTO(SUBTOTAL(3;DESLOC($A$7;LIN($A$7:$A$27)-LIN($A$7);0));($A$7:$A$27=A2)+0) Abraço

Sub PDF()
'
' PDF Macro
' Salvar em PDF
'
Dim FileName As String
FileName = Application.GetSaveAsFilename
If Right(FileName, 1) = "." Then
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$A$1:$I$36"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintSheetEnd
.PrintQuality = 1200
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 55
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
ActiveSheet.ExportAsFixedFormat Type:=0, FileName:=FileName, Quality:=0, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End If
End Sub

Diego,
 
O problema é que na célula AU19 existe uma barra "/* e esse caractere não é aceito como parte do nome de um arquivo. Se você tentar renomear um arquivo manualmente com esse valor verá que não é possível.
 
Uma opção seria substituir a barra por outra coisa no código, exemplo::
NameFile = Replace([AU19], "/", "_") & ".xls" Abraço

São cerca de 18 mil linhas e 16 colunas precisam são mescladas, então vai demorar para rodar e vai parecer que o Excel travou, mas não é isso:
Sub Juliana_Varela()Dim r As Long, i As Long, c As LongOn Error GoTo ESCApplication.Calculation = xlCalculationManualApplication.ScreenUpdating = FalseFor r = Cells(Rows.Count, 17).End(xlUp).Row To 2 Step -1 If Cells(r, 17) = "" Then Rows(r).Delete Else If i = 0 And Cells(r, 1) = "" Then i = r If i > 0 And Cells(r, 1) <> "" Then For c = 1 To 16 Range(Cells(r, c), Cells(i, c)).Merge Next i = 0 End If End IfNextESC:Application.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticIf Err.Number = 0 Then MsgBox "Done!", vbInformation, "#Informação"End Sub Importante: Se o número do processo estiver em branco a linha será deletada, então será necessário corrigir linhas como essas:
 
 
 

Jorge,
 
Supondo que a data que você queira checar esteja na célula A1, clique com o botão direito sobre a aba que deseja inserir a macro (como se fosse renomeá-la) e clique em Exibir Código.
 
Em seguida cole o código abaixo:
Private Sub Worksheet_Calculate() If Range("A1") > Date - 30 Then MsgBox "A data expirou", vbExclamation, "#Atenção"End Sub Abraço

Olá,
 
Veja se era isso que precisava. 
 
Como são arquivos separados você terá que atualizar o local onde o Banco de Dados está salvo, caso precise de ajuda use o documento Word anexo.
 
Abraço
ORÇAMENTO ENIVALDO.xlsx
Atualizar Links.docx

Olá Nocte,
 
Não tenho certeza se o código abaixo funciona em versões anterioriores ao Excel 2010, mas deu acerto na minha máquina:
Sub Group()Dim Color As Long, r As Long, x As LongColor = 13369344For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(r, 1).DisplayFormat.Font.Color = Color And Cells(r - 1, 1).DisplayFormat.Font.Color = 0 Then x = r If Cells(r, 1).DisplayFormat.Font.Color = Color And Cells(r + 1, 1).DisplayFormat.Font.Color = 0 Then Rows(x & ":" & r).Group End IfNextEnd Sub Caso não funcione sugiro que nos diga exatamente qual é o critério aplicado na sua planilha para formatar a cor da fonte.
 
Com base no seu seu segundo exemplo o código ficaria assim:
Sub Group_2()Dim r As Long, x As LongFor r = 2 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(r, 3) = "s" And Cells(r - 1, 3) = "" Then x = r If Cells(r, 3) = "s" And Cells(r + 1, 3) = "" Then Rows(x & ":" & r).Group End IfNextEnd Sub Abraço

Olá @ffilgueira1000
 
Veja se consegue seguir esse passo a passo:
 
1) Crie um módulo na sua planilha e cole o código da função abaixo:
Public Function IsSelected(ByVal Target As Range) As Boolean Application.Volatile If Target.Row = ActiveCell.Row Or Target.Column = ActiveCell.Column Then IsSelected = True End IfEnd Function 2) Clique botão direito no nome da aba que você quer aplicar essa formatação (Como se fosse renomeá-la) e  depois clique em Exibir Código. Em seguida cole o código abaixo:
Private Sub Worksheet_SelectionChange(ByVal Target As Range) IsSelected Target CalculateEnd Sub 3) Clique no intervalo de células que deseja aplicar essa formatação (no meu exemplo B10:H30), clique no botão Formatação Condicional (Disponível na guia Página Inicial) e depois em Nova Regra. Agora selecione a opção Usar uma fórmula para determinar quais células devem ser formatadas e forneça o seguinte valor:
=IsSelected(B10) Obs: Substitua B10 pela primeira célula do seu intervalo
 
4) Clique em formatar e na janela que abrir navegue até a guia Preenchimento para selecionar a cor desejada.
 
 

Olá,
 
Veja se é isso que precisa.
 
Abraço
Pasta1.zip

Boa tarde,
 
Experimente pressionar CTRL + SHIFT + ( 
 
ou
 
Clique no botão circulado em vermelho da imagem anexa.
 
Abraço
 
   

Olá,
 
Acredito que seria mais fácil substituir o código por esse:
 
If Target.Row > 2 And Target.Column = 10 Then Target.Offset(0, 1).Formula = Replace(Cells(2, 11).Formula, "2", Target.Row)End If Se alguma célula da coluna de número 10 for alterada a fórmula da coluna 11 será replicada na linha em questão.