Ir ao conteúdo
  • Cadastre-se

AfonsoMira

Membro Pleno
 Perfil  Explorar Conteúdo

  • Posts

    463

  • Cadastrado em

  • Última visita

 Tipo de conteúdo 

posts postados por AfonsoMira

    Tem como fazer um botão para apagar linha da tabela ?

    em Microsoft Office e similares

    Postado

    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. 🙂

    • Obrigado 1

    VBA - como usar find para achar texto copiado

    em Microsoft Office e similares

    Postado

    Boas @isabela queiroz ,
    Seria algo deste género:
      

    Sub procura()

Windows(" BOM.CO").Activate

Cells.Find(What:="PN", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Select

ActiveCell.Offset(1, 0).Select

'Define o valor da Variavel
valorProcura = ActiveCell.Value

Sheets("Pier Distribution").Select

'Procura a variavel
Cells.Find(What:=valorProcura, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Select

End Sub

     

    Como somar e Armazenar valores de uma coluna para Outra ?

    em Microsoft Office e similares

    Postado

    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

     

    VBA excel montar arquivo JSON

    em Microsoft Office e similares

    Postado

    Boas,

    Penso que assim já resolveria:
      

    Sub export_in_json_format()

    Dim fs As Object
    Dim jsonfile
    Dim rangetoexport As Range
    Dim rowcounter As Long
    Dim columncounter As Long
    Dim linedata As String
    Dim UltimaLinhaAtivaE As Long
    Dim UltimaLinhaAtivaG As Long
    Dim UltimaLinhaAtivaH As Long
    Dim UltimaLinhaAtivaL As Long
    Dim UltimaLinhaAtivaN As Long
    Dim UltimaLinhaAtivaO As Long
    Dim UltimaLinhaAtivaP As Long
    Dim r1 As Range
    Dim r2 As Range
    Dim r3 As Range
    Dim r4 As Range
    Dim r5 As Range
    Dim r6 As Range
    Dim r7 As Range
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.ActiveSheet
    
    With ws
        UltimaLinhaAtivaE = .Cells(.Rows.Count, 5).End(xlUp).Row
        UltimaLinhaAtivaG = .Cells(.Rows.Count, 7).End(xlUp).Row
        UltimaLinhaAtivaH = .Cells(.Rows.Count, 7).End(xlUp).Row
        UltimaLinhaAtivaL = .Cells(.Rows.Count, 12).End(xlUp).Row
        UltimaLinhaAtivaN = .Cells(.Rows.Count, 14).End(xlUp).Row
        UltimaLinhaAtivaO = .Cells(.Rows.Count, 15).End(xlUp).Row
        UltimaLinhaAtivaP = .Cells(.Rows.Count, 16).End(xlUp).Row
        
        Set r1 = .Range("N1:N" & UltimaLinhaAtivaN)
        Set r2 = .Range("O1:O" & UltimaLinhaAtivaO)
        Set r3 = .Range("P1:P" & UltimaLinhaAtivaP)
        Set r4 = .Range("H1:H" & UltimaLinhaAtivaH)
        Set r5 = .Range("G1:G" & UltimaLinhaAtivaG)
        Set r6 = .Range("L1:L" & UltimaLinhaAtivaL)
        Set r7 = .Range("E1:E" & UltimaLinhaAtivaE)
    End With
    
    
    
    ' change range here
    Set rangetoexport = Union(r1, r2, r3, r4, r5, r6, r7)

    Set fs = CreateObject("Scripting.FileSystemObject")
    ' change dir here
    
    Set jsonfile = fs.CreateTextFile("C:\Users\erick.l.santiago\Desktop\" & "jsondata.json", True)
    
    linedata = "{""Output"": ["
    jsonfile.WriteLine linedata
    For rowcounter = 2 To rangetoexport.Rows.Count
        linedata = ""
        For columncounter = 1 To 7
            linedata = linedata & """" & rangetoexport.Cells(1, columncounter) & """" & ":" & """" & rangetoexport.Cells(rowcounter, columncounter) & """" & ","
        Next
        linedata = Left(linedata, Len(linedata) - 1)
        If rowcounter = rangetoexport.Rows.Count Then
            linedata = "{" & linedata & "}"
        Else
            linedata = "{" & linedata & "},"
        End If
        
        jsonfile.WriteLine linedata
    Next
    linedata = "]}"
    jsonfile.WriteLine linedata
    jsonfile.Close
    
    Set fs = Nothing
    
End Sub

     

    vba - FIND para localizar colunas

    em Microsoft Office e similares

    Postado 

    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

     

    • Amei 1

    vba - FIND para localizar colunas

    em Microsoft Office e similares

    Postado

    Boas @isabela queiroz ,
    Experimente o seguinte:

      

    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

MsgBox "A palavra Cliente aparece na coluna " & colunaCliente & " e a palavra Numero na coluna " & colunaNumero

End Sub

     

    • Amei 1

    VBA - como fazer um IF que tenha a condição de uma certa palavra

    em Microsoft Office e similares

    Postado

    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

     

    • Amei 1

    VBA - como fazer um IF que tenha a condição de uma certa palavra

    em Microsoft Office e similares

    Postado

    Boas @Scofieldgyn ,
    Veja se isto 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)
            'Define o valor na célula
            ws.Cells(i, 2) = valor
        Else
            ws.Cells(i, 2).Value = valor
        End If
    Next i
End Sub

     

    • Amei 2

    Erro em tempo de execução '91: Access Vba

    em Microsoft Office e similares

    Postado

    Boas, @Kleber Bispo
    Tente alterar a seguinte parte do código:
      

    	consulta2 = "SELECT * FROM Dados WHERE nome =" & "'" & nome_do_loop(i) & "'"
    Set rs2 = banco.OpenRecordset(consulta2, dbOpenSnapshot) 'Realiza 2ª consulta no Banco de Dados
       
    Set wb = xl.Workbooks.Open(nome_arquivo_excel)  'Abre o arquivo excel criado
    Set ws = ActiveSheet    'Define a planilha ativa
    
    ws.Range("A2").CopyFromRecordset rs2 'Copia o Recordset para o arquivo excel
    wb.Save 'Salva arquivo Excel
    wb.Close 'Fecha arquivo Excel
    rs2.Close
    
    Set rs2 = Nothing   'Limpa Recordset
    Set ws = Nothing    'Limpa a variável ws
    Set wb = Nothing    'Limpa a variável wb


    Para:
      

    	Set banco = CurrentDb 'Inicializa a conexão
    consulta2 = "SELECT * FROM Dados WHERE nome =" & "'" & nome_do_loop(i) & "'"
    Set rs2 = banco.OpenRecordset(consulta2, dbOpenSnapshot) 'Realiza 2ª consulta no Banco de Dados
       
    Set wb = xl.Workbooks.Open(nome_arquivo_excel)  'Abre o arquivo excel criado
    Set ws = ActiveSheet    'Define a planilha ativa
    
    ws.Range("A2").CopyFromRecordset rs2 'Copia o Recordset para o arquivo excel
    wb.Save 'Salva arquivo Excel
    wb.Close 'Fecha arquivo Excel
    rs2.Close
    
    Set banco = Nothing 'Fecha conexão
    Set rs2 = Nothing   'Limpa Recordset
    Set ws = Nothing    'Limpa a variável ws
    Set wb = Nothing    'Limpa a variável wb

     

    tem alguma forma de usar python no excel?

    em Microsoft Office e similares

    Postado

    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
     

    Em 09/09/2022 às 17:13, Midori disse:

    No próprio Excel só é possível em VBA.

    • Obrigado 1

    Exibir o conteúdo das células durante 15 segundos.

    em Microsoft Office e similares

    Postado

    Boas @GENECIOFICIAL ,
    Veja se é isto que pretende:
      

    Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address = "$A$1" Then
    
    'Coloca Valor
    ActiveSheet.Range("B1").Formula2R1C1 = "=IFERROR(INDEX(INDIRECT(""$B$""&ROW(XLOOKUP(RC[-1],R2C1:R151C1,R2C2:R151C2))):R[150]C, MATCH(FALSE,INDIRECT(""$B$""&ROW(XLOOKUP(RC[-1],R2C1:R151C1,R2C2:R151C2))):R[150]C="""",0)),""Não existe valor"")"
    
    'Tempo de Pausa
    Application.Wait (Now + TimeValue("0:00:15"))
    
    'Retira Valor
    ActiveSheet.Range("B1").Value2 = ""
End If

End Sub

     

    código de VBA em minha pasta de trabalho dando erro

    em Microsoft Office e similares

    Postado

    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 🙂

    • Curtir 1

    VBA - Se valor contido é verdadeiro - preencher coluna com outro valor.

    em Microsoft Office e similares

    Postado 

    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.

    • Curtir 1

    VBA salvar planilha nome variavel

    em Microsoft Office e similares

    Postado

    Boas @Quedison Nunes Alves ,

    Experimente assim:
      

    Sub SavaCopia_envia_Email()

    Dim contador As Integer
    Dim caminho As String: caminho = "C:\Users\Nunes\Desktop\PROJETO\Teste\BKPDOCUMENTO\"
    Dim nomeCopia As String: nomeCopia = "Relatório_" & VBA.Format(VBA.Now, "dd-mm-yyyy") & "." & contador & ".xlsx"
    Dim dirCopia As String: dirCopia = caminho & nomeCopia
    Dim verifica_existe As String

    verifica_existe = Dir(dirCopia)

    Do While verifica_existe <> ""
        contador = contador + 1
        nomeCopia = "Relatório_" & VBA.Format(VBA.Now, "dd-mm-yyyy") & "." & contador & ".xlsx"
        dirCopia = caminho & nomeCopia
        verifica_existe = Dir(dirCopia)
    Loop

    ThisWorkbook.SaveAs Filename:= _
                        caminho + nomeCopia, _
                        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
                        ReadOnlyRecommended:=False, CreateBackup:=False

    Dim sPara      As String
    Dim sMsg       As String
    Dim sAssunt    As String

    'Enviar e-mail
    nomeCopia = "Relatório_" & VBA.Format(VBA.Now, "dd-mm-yyyy") & "." & contador & ".xlsx"
    sAssunt = "Assunto de Envio de Relatório em Anexo"
    sMsg = "Mensagem teste de envio de e-mail com anexo"

    Dim OutlookApp   As Object
    Dim OutlookMail  As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    With OutlookMail
        .to = ""
        .CC = ""
        .BCC = ""
        .Subject = sAssunt
        .Body = sMsg
        .Attachments.Add dirCopia
        .Display                                 ' para envia o email diretamente defina o código  .Send
    End With

    Set OutlookMail = Nothing
    Set OutlookApp = Nothing

End Sub

     

    • Curtir 1

    VBA - Se valor contido é verdadeiro - preencher coluna com outro valor.

    em Microsoft Office e similares

    Postado

    Boas @ffialho ,

    Veja se isto ajuda:
      

    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.Cells(i, 6).Value

'Loop por cada linha da Folha Recebidos
For x = 2 To UltLinhaRecebidos
    
    'Recebe Chave Recebidos
    chaveRecebidos = wsRecebidos.Cells(i, 7).Value
    
    'Se Chave Recebidos contem Chave Faturado então
    If InStr(1, chaveRecebidos, chaveFaturado, vbTextCompare) <> 0 Then
        'Coloca Data vencimento na Folha Faturado
        wsFaturado.Cells(i, 8).Value = wsRecebidos.Cells(i, 6).Value
    End If

Next x

Next i

End Sub

     

    • Curtir 1

    Função SE e SOMASES com VBA

    em Microsoft Office e similares

    Postado

    Em 29/07/2022 às 17:02, JorgeSouza disse:

    Que monte de "R" e "C" são esses? Esses números também, o que eles significam?


    Boas, o "R" é referente a a linha e o "C" a Coluna.
    R1C1 = A Linha 1 e Coluna 1 = Range("A1")

    Neste exemplo temos

     

    Em 29/07/2022 às 17:02, JorgeSouza disse:

    RC[-1]


    Aqui tomamos como ponto de partida a célula onde vai a fórmula:
     

     

    Em 29/07/2022 às 17:02, JorgeSouza disse:

    ws.Range("D4").FormulaR1C1 = "=IFERROR(IF(R1C1=R1C7,SUMIFS(C[5],C[3],RC[-2],C[4],RC[-1],C[2],RC[-3])),0)"


    Ou seja, sendo que a fórmula vai na célula "D4"
    Temos que R é igual ou seja 4 e C é -1, ou seja, Coluna 4 ("D") - 1 = Coluna 3 ("C")

    Artigo com melhor explicação


     

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

Mais

×
×
  • Criar novo...