AfonsoMira

@Thonymah Boas experimente o seguinte:
1º - Abra as definições do Windows.
 
2º - Clique em Rede e Internet.
 
3º - Clique em Estado.
 
4º - Clique em Alterar opções do adaptador.
 

 
5º - Clique com o botão direito na rede que pretende dar prioridade e selecione propriedades.
 
6º - Selecione o item que diz "Internet Protocol Version 4 (TCP/IPv4)"
 
7º - Clique em propriedades.
 

 
8º - Na aba Geral, clique no botão avançadas.
 

 
9º - Desmarque a caixa de métrica automática
 

 
10º - Adicione um número à métrica. Por exemplo 1 que é prioridade máxima.(Quando menor o número maior prioridade, e vice-versa).
 
11º - Clique no botão de OK
 
12º - Clique no botão de OK novamente
 
13º - Clique em fechar.
 
Espero que tenha ajudado e resolvido o seu problema.

 

Boas @Arthur Guillermo ,

Com recurso a Macro (VBA)

Aqui fica o código, que precisa associar aos Botões.
 
Sub LimparTabela() Dim T As ListObject: Set T = ActiveSheet.ListObjects(1) With T.DataBodyRange If .Rows.Count > 1 Then .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete On Error Resume Next .Rows(1).SpecialCells(xlCellTypeConstants).ClearContents End With End Sub Sub LimparLinhaSelecionada() Dim rng As Range On Error Resume Next With Selection.Cells(1) Set rng = Intersect(.EntireRow, ActiveCell.ListObject.DataBodyRange) On Error GoTo 0 If rng Is Nothing Then MsgBox "Por Favor Selecione a Linha que pretende Eliminar", vbCritical Else If ActiveCell.Row = 2 Then On Error Resume Next Rows(2).SpecialCells(xlCellTypeConstants).ClearContents On Error GoTo 0 Else rng.Delete xlShiftUp End If End If End With End Sub
Alguma dúvida disponha. 🙂

Boas, @SrMths
Isso é possível com recurso a Macro.

Veja um exemplo:
 
Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False Dim wb As Workbook: Set wb = ThisWorkbook Dim ws As Worksheet: Set ws = wb.ActiveSheet Dim azul As Range: Set azul = ws.Range("B1") Dim laranja As Range: Set laranja = ws.Range("A1") laranja.Value = laranja.Value + azul.Value azul.Value = "" Application.EnableEvents = True Application.ScreenUpdating = True End Sub  

Sub procurarColunas() Dim wb As Workbook: Set wb = ThisWorkbook Dim ws As Worksheet: Set ws = wb.ActiveSheet Dim rngProcura As Range: Set rngProcura = ws.Range("A1:XFD1048576") Dim rngCliente As Range Dim rngNumero As Range Dim colunaCliente As Long Dim colunaNumero As Long With rngProcura Set rngCliente = .Find(what:="Cliente", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False) If Not rngCliente Is Nothing Then colunaCliente = rngCliente.Column End If Set rngNumero = .Find(what:="Numero", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False) If Not rngNumero Is Nothing Then colunaNumero = rngNumero.Column End If End With 'Copia coluna Cliente ws.Columns(colunaCliente).Copy 'Copia coluna Numero ws.Columns(colunaNumero).Copy End Sub  

Boas @isabela queiroz ,
Desculpe a demora na resposta
Veja se assim ajuda:
 
Sub CriarTemplate() 'Declara Variaveis de Livro e Folha Dim wb As Workbook: Set wb = ThisWorkbook Dim ws As Worksheet: Set ws = wb.Sheets("Produto") 'Declara Variavel ultima Linha Dim ultLinha As Long ultLinha = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Desde a linha 2 até a ultima For i = 2 To ultLinha valor = ws.Cells(i, 1) 'Se "-" existir então If InStr(valor, "-") Then 'Divide valor = Split(valor, "-")(1) 'Remove espaços em branco valor = Trim(valor) If valor = "MALDIVES 6U" Then valor = valor & " " & Left(ws.Cells(i, 1), 3) End If 'Define o valor na célula ws.Cells(i, 2) = valor Else ws.Cells(i, 2).Value = valor End If Next i End Sub  

Boas @Swalls ,

Alternativa Paga

Programar em Python e chamar no Excel (VBE) utilizando o pyxll.

Por exemplo o seguinte código em Python:
 
from pyxll import xl_macro, xlcAlert @xl_macro def mensagem_popUp(): xlcAlert("Olá, Mundo")  
Depois no VBE (Visual Basic Editor), chama o código Python através do seguinte código:
 
Sub SubRotinaVBA x = Run("mensagem_popUp") End Sub  
Alternativa Grátis
 
Utilizando o xlwings junto com o numpy.
 
Código em Python:
 
# olaMundo.py import numpy as np import xlwings as xw def mundo(): wb = xw.Book.caller() wb.sheets[0].range('A1').value = 'Olá, Mundo'  
Depois no VBE (Visual Basic Editor), chama o código Python através do seguinte código:
 
Sub OlaMundo() RunPython ("import olaMundo; olaMundo.mundo()") End Sub  
Mas como disse o @Midori
 

Boas @Bruno Rimoldi ,

Veja se ajuda:
 
Set fso = CreateObject("Scripting.FileSystemObject") ficheiro = fso.getFileName(Filename)  
"=VLOOKUP(RC[-5],'" & ficheiro & "'!C35:C147,113,1)"
 

Sub verificarValor() 'Declara Livro Dim wb As Workbook: Set wb = ThisWorkbook 'Declara Folhas Dim wsRecebidos As Worksheet: Set wsRecebidos = wb.Sheets("Recebidos") Dim wsFaturado As Worksheet: Set wsFaturado = wb.Sheets("Faturado") 'Declara Ultimas Linhas das Folhas Dim UltLinhaRecebidos As Long: UltLinhaRecebidos = wsRecebidos.Cells(wsRecebidos.Rows.Count, "A").End(xlUp).Row Dim UltLinhaFaturado As Long: UltLinhaFaturado = wsFaturado.Cells(wsFaturado.Rows.Count, "A").End(xlUp).Row Dim i, x As Long Dim chaveFaturado As String Dim chaveRecebidos As String 'Loop por cada linha da Folha Faturado For i = 2 To UltLinhaFaturado 'Recebe Chave Faturado chaveFaturado = wsFaturado.Range("AB" & i).Value 'Loop por cada linha da Folha Recebidos For x = 2 To UltLinhaRecebidos 'Recebe Chave Recebidos chaveRecebidos = wsRecebidos.Range("U" & x).Value 'Se Chave Recebidos contem Chave Faturado então If InStr(1, chaveRecebidos, chaveFaturado, vbTextCompare) <> 0 Then 'Coloca Data vencimento na Folha Faturado wsFaturado.Range("AC" & i).Value = wsRecebidos.Range("G" & x).Value End If Next x Next i End Sub Para resolver a questão das colunas novas.

Já para a parte da Data mais antiga terei que pensar em algo.

Boas @Osmarbg ,
Experimente assim:

 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'Primeira Macro Dim LR As Long, X As String If Target.Count > 1 Then Exit Sub If Target.Column = 10 And Target.Value = "A" Then X = "Itau - Alimenta" If Target.Column = 10 And Target.Value = "G" Then X = "BRADESCO - Golden" If X <> vbNullString Then With Sheets(X) LR = .Cells(4501, 1).End(3).Row On Error GoTo res Application.EnableEvents = False .Cells(LR + 1, 1).Resize(, 5).Value = Cells(Target.Row, 2).Resize(, 5).Value .Cells(LR + 1, 😎 = Cells(Target.Row, 9) .Cells(LR + 1, 10).Resize(, 2).Value = Cells(Target.Row, 11).Resize(, 2).Value res: Application.EnableEvents = True End With End If 'Segunda Macro Dim UL As Long If Sh.Name = "Itau - Alimenta" Or Target.Count > 1 Then Exit Sub If Target.Column <> 10 Or Target.Value <> "C" Then Exit Sub Application.ScreenUpdating = False With Sheets("Itau - Alimenta") UL = .Cells(4500, 1).End(xlUp).Row Cells(Target.Row, 2).Resize(, 5).Copy .Cells(UL + 1, 1) Cells(Target.Row, 8).Resize(, 5).Copy .Cells(UL + 1, 7) End With End Sub

Ps. Não testei aqui 🙂

Boas @Esraeu ,
Experimente assim:
 
=SE(A1="Fiesta";D1;SE(OU(A1="Gol";A1="Palio";A1="Chevette");D2;D3))
Utilizando a função OU após o SE, pode acrescentar mais que 1 critério.

Material para ler: Aqui

Boas @Bruno Rimoldi ,

Experimente assim:
 
=PROC(2,1/('Item a Item Julho 2022'!A:A=Sheet1!A2),'Item a Item Julho 2022'!B:B)  
Caso não dê, troque a "," por ";".

Esta fórmula faz um Proc ao contrário.

Boas @JorgeSouza ,
 
Experimente o seguinte código:
 
Sub soma_se() 'Declara Variavel Livro Dim wb As Workbook: Set wb = ThisWorkbook 'Declara Variavel Folha Dim ws As Worksheet: Set ws = wb.ActiveSheet 'Vai buscar ultima linha da Coluna A Dim ultimaLinha As Long: ultimaLinha = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Coloca formula na célula D4 ws.Range("D4").FormulaR1C1 = "=IFERROR(IF(R1C1=R1C7,SUMIFS(C[5],C[3],RC[-2],C[4],RC[-1],C[2],RC[-3])),0)" 'Arrasta da D4 até D e ultima linha ws.Range("D4").AutoFill Destination:=ws.Range("D4:D" & ultimaLinha), Type:=xlFillDefault 'Converte fórmula em Valor ws.Range("D4:D" & ultimaLinha).Value2 = ws.Range("D4:D" & ultimaLinha).Value2 End Sub  

Boas @Jeff_Sandes ,

Então ao que parece o VBA está a associar o "/" da data como sendo um separador do caminho do ficheiro.

Experimente desta forma:
 
Private Sub Salvar_Planilha() Dim Data As String Data = Format(Date, "mm-yyyy") ActiveWorkbook.SaveAs _ Filename:="C:\Users\Automacao\Desktop\macros\" & Data & ".xlsm" 'Salva planilha com nome de mês e data atual Application.DisplayAlerts = False 'Desativa Pop-Up de pergunta se deseja salvar ou não Application.Quit 'Fecha Excel End Sub  
Ps. Não testei aqui

Eu errei aqui,
Experimenta agora: 
"=PICurrVal(""\\FTHSERVER\BWF_530BWF_SP_OP"",0,"""")"  

Boas, @Revolucao
Experimente formatar a célula com o seguinte:
 
**;**;**;**  
Como no exemplo:

Boas, @Gustavo1313
 
Experimente usar a formula "SE".
 
Se o resultado for 0 então escreve branco.
 
Algo deste género:
 
=SE(SOMA($B$7:B8)/$B$3=0,"",SOMA($B$7:B8)/$B$3)  

Boas, @Gustavo1313
 
Experimente usar a formula "SE".
 
Se o resultado for 0 então escreve branco.
 
Algo deste género:
 
=SE(SOMA($B$7:B8)/$B$3=0,"",SOMA($B$7:B8)/$B$3)  

Boas, @Gustavo1313
 
Experimente usar a formula "SE".
 
Se o resultado for 0 então escreve branco.
 
Algo deste género:
 
=SE(SOMA($B$7:B8)/$B$3=0,"",SOMA($B$7:B8)/$B$3)  

Boas, @Gustavo1313
 
Experimente usar a formula "SE".
 
Se o resultado for 0 então escreve branco.
 
Algo deste género:
 
=SE(SOMA($B$7:B8)/$B$3=0,"",SOMA($B$7:B8)/$B$3)  

@Revolucao Boas,
 
Veja se é isto que pretende?
Bolão-formatação.xlsx
Cumps,
Afonso Mira

@Martti Boas,
 
Veja se é isto que deseja:
 
Sub PASS_TEST() '*********************************************************** Dim ROUTER1, ROUTER2, TABELAB As Range Dim ultLinha As Integer Dim resultado_procv As Variant Dim i As Integer Application.ScreenUpdating = False ultLinha = Sheets("Plan2").Cells(Cells.Rows.Count, 1).End(xlUp).Row Set TABELAB = Sheets("REF").Range("a2:c668") Sheets("Plan2").Select For i = 2 To ultLinha Set ROUTER1 = Sheets("Plan2").Range("K" & i) Set ROUTER2 = Sheets("Plan2").Range("Q" & i) If ROUTER1 <> "" Then resultado_procv = Application.VLookup(ROUTER1, TABELAB, 2, False) Sheets("Plan2").Range("BC" & i).Value = resultado_procv resultado_procv = Application.VLookup(ROUTER1, TABELAB, 3, False) Sheets("Plan2").Range("BD" & i).Value = resultado_procv ElseIf ROUTER1 = "" Then resultado_procv = Application.VLookup(ROUTER2, TABELAB, 2, False) Sheets("Plan2").Range("BC" & i).Value = resultado_procv resultado_procv = Application.VLookup(ROUTER2, TABELAB, 3, False) Sheets("Plan2").Range("BD" & i).Value = resultado_procv End If Next i End Sub  

@Rodrigues77  Veja se ajuda.

A macro altera os valores do ano e do mês na Plan2.

 

 
Modelo Dashboard.zip

Boas,
Este foi o resultado mais próximo ao que consegui chegar daquilo que pede.
Veja se lhe ajuda.
1889839985_PreoxHistrico.xls

@Guilhermepa3
Veja se agora já está como pretende?
 
Formulário Orçamento -atualizado - Copia OK.xlsx

Boas @Luciana Goes,
 
Substitua todo o seu código por esse: 
Private Sub UserForm_Initialize() TextBox1.Text = Plan1.Range("b3").Value TextBox2.Text = Plan1.Range("c3").Value TextBox3.Text = Plan1.Range("d3").Value TextBox1_AfterUpdate End Sub Private Sub TextBox1_AfterUpdate() valor2 = Right(TextBox2.Value, Len(TextBox2.Value) - 3) If TextBox1.Value < 0 Then TextBox4.Value = valor2 * CDbl(TextBox1.Value) ElseIf TextBox1.Value >= 0 Then TextBox4.Value = valor2 * TextBox3.Value End If End Sub Private Sub TextBox2_Change() TextBox2.Value = VBA.Format(TextBox2.Value, "R$ ###,##0.00") TextBox2.TabStop = False End Sub  
Espero ter ajudado.