Ir ao conteúdo
  • Cadastre-se

AfonsoMira

Membro Pleno
  • Posts

    463
  • Cadastrado em

  • Última visita

  1. 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.
  2. 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
  3. Boas, @Miguelriedel Seria algo deste género: Dim NovaTextBox As Control Set NovaTextBox = Me.Controls.Add("Forms.TextBox.1", "NovaTextBoxTeste", True) With NovaTextBox .Width = 90 .Height = 30 .Top = 36 .Left = 66 End With
  4. 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
  5. Boas @Vinicius3145353 , Experimente algo deste género: =PROCV(D8;Tabela5;2)&","&PROCV(D8;Tabela6;2)
  6. 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
  7. 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
  8. 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
  9. 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
  10. 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
  11. Boas @Jeff_Sandes , Experimente assim: "=((@PIArcVal('\\FTHSERVER\ACS_540SE01M1.V';'28/08/2022 0:00:00';0;'';'auto')/0,8333)*0,05617978)" Ps. Não testei
  12. 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
  13. Boas @artur251209 , Não perde o Save, ele fica gravado na Cloud.
  14. 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
  15. Boas @Jeffersonthedarks , Consegue anexar o ficheiro para podermos ajudar melhor. Obrigado

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

×
×
  • Criar novo...