Muca Costa

Veja se dá pra adaptar às suas necessidades: Private Sub Workbook_Open() Dim quantas As Integer, tenta As Integer, senha As String, dt As Date 'Escolha a data em a Pasta de Trabalho deverá expirar (ano, mês, dia) dt = DateSerial(2021, 12, 31) tenta = 3 quantas = 0 If Date >= dt Then MsgBox "Esta Pasta de Trabalho expirou! Favor contatar o administrador através do e-mail [email protected] ou pelo WhatsApp (31) 99610-8436." ThisWorkbook.Close SaveChanges:=False End If volta: senha = InputBox("Digite a senha") If senha = "123" Then MsgBox "Seja bem vindo", vbInformation, "© Muca Sistemas - 2021" Else quantas = quantas + 1 If quantas >= tenta Then ActiveWorkbook.Close SaveChanges:=False End Else MsgBox "Você tem " & tenta - quantas & " tentativa(s)", vbInformation, "© Muca Sistemas - 2021" GoTo volta End If End If End Sub

Veja se ajuda: Execute a Sub Arrumar() Sub Arrumar() Extrair Excluir Finalizar Columns("A:B").Select Selection.Delete Shift:=xlToLeft Range("A1").Select End Sub Sub Extrair() Dim P As String, Ultimalinha As String, Lin As String, i As Integer With ActiveSheet P = .Cells(.Rows.Count, "A").End(xlUp).Row End With Ultimalinha = Planilha1.Cells(Rows.Count, "A").End(xlUp).Row Lin = 1 For i = 1 To Ultimalinha Planilha1.Cells(Lin, 2) = Left(Planilha1.Cells(i, 1), 5) Lin = Lin + 1 Next End Sub Sub Excluir() Dim LR As Long, k As Long LR = Cells(Rows.Count, "A").End(xlUp).Row Application.ScreenUpdating = False For k = LR To 1 Step -1 If Cells(k, "A").Value <> "" Then c1 = Cells(k, "A").Replace("NF:", "", xlPart) c2 = Cells(k, "A").Replace("/", "", xlPart) c3 = Cells(k, "A").Replace("PLC:", "", xlPart) c4 = Cells(k, "A").Replace(". I ", "", xlPart) c5 = Cells(k, "A").Replace(".", "", xlPart) c6 = Cells(k, "A").Replace("-", "", xlPart) c7 = Cells(k, "A").Replace("0", "", xlPart) c8 = Cells(k, "A").Replace("1", "", xlPart) c9 = Cells(k, "A").Replace("2", "", xlPart) c10 = Cells(k, "A").Replace("3", "", xlPart) c11 = Cells(k, "A").Replace("4", "", xlPart) c12 = Cells(k, "A").Replace("5", "", xlPart) c13 = Cells(k, "A").Replace("6", "", xlPart) c14 = Cells(k, "A").Replace("7", "", xlPart) c15 = Cells(k, "A").Replace("8", "", xlPart) c16 = Cells(k, "A").Replace("9", "", xlPart) c17 = Cells(k, "A").Replace("/", "", xlPart) End If Next k Application.ScreenUpdating = True Range("A1").Select End Sub Sub Finalizar() Dim P As String, Ultimalinha As String, Lin As String, i As Integer With ActiveSheet P = .Cells(.Rows.Count, "A").End(xlUp).Row End With Ultimalinha = Planilha1.Cells(Rows.Count, "A").End(xlUp).Row Lin = 1 For i = 1 To Ultimalinha Planilha1.Cells(Lin, 3) = Planilha1.Cells(i, 2) & Planilha1.Cells(i, 1) Lin = Lin + 1 Next End Sub

Tente isso: import sys import subprocess path = 'Informe o diretório dos scripts' arquivos = [path + '\Script1.py', path + '\Script2.py', path + '\Script3.py', path + '\Script4s.py', path + '\Script5.py'] processos = [] for arquivo in arquivos: processo = subprocess.Popen([sys.executable, arquivo]) processos.append(processo) # neste ponto todos os scripts estão rodando em background ao mesmo tempo. # Vamos esperar todos eles terminarem: for processo in processos: processo.wait()

Tente assim: Sub Abrir_Exel_ou_Não() Dim RESPOSTA As Integer, ANS As Integer, xls As Object, excel As String RESPOSTA = vbYesNo + vbQuestion + vbDefaultButton2 ANS = MsgBox("Deseja Acesso os Dados?", RESPOSTA, "Prosseguir") If ANS = vbYes Then Set xls = CreateObject("Excel.Application") excel = "C:\Sistema_Certificados_Venda\Dados.xlsm" xls.Workbooks.Open (excel) xls.Visible = True Else End If ActiveDocument.Save Application.Quit End Sub

Tente assim: def __init__(self, username, password): def login(self):

Tente assim: import os dir = 'D:\Downloads\Muca' #Cria diretídio Muca os.makedirs(dir) arquivo = open(dir + '\Arq.txt','w') #Cria arquivo Arq.txt arquivo.write("Número: 010010\nCanção: Teste\nCantor: TESTE\nInício: T e s t e") arquivo.close()

O código abaixo se destina a copiar texto de vários docx e colar, um seguido do outro, em um outro docx(Principal.docx. Funciona bem para pequenos textos (10 linhas por exemplo); porém quando o texto é longo ele até copia parte do texto, porém dá erro: File "d:/Documents/Cina/TRT 15/Estruturas/Python/Estrutura.py", line 13, in <module> PermissionError: [Errno 13] Permission denied: 'D:\\Documents\\Cina\\TRT 15\\Estruturas\\Python\\Principal.docx' Solicito ajuda para solucionar... import os from docx import Document from tkinter import filedialog as dlg Dir = (os.path.dirname(os.path.realpath(__file__))) #Diretório atual path = dlg.askopenfilename() document = Document(path) for p in document.paragraphs: #print(p.text) doc=Document(Dir + '\Principal.docx') paragraph = doc.add_paragraph(p.text) doc.save((Dir) + '\Principal.docx') #salve-o no sistema de arquivos os.startfile((Dir) + '\Principal.docx') #abre o arquivo Principal.docx

Se for possível, anexe suas planilhas.

Veja se dá pra adaptar o exemplo anexo... DadosOutraPlanilha.rar

A Aba General é atualizada automaticamente de acordo com as informações inseridas na Base de Dados...

Veja se ajuda: Os eventos abaixo objetivam percorrer os códigos da coluna A informando, automaticamente, na célula F3 o item selecionado na coluna A. Basta você incluir sua macro de cálculos, exportação para PDF, etc.. Evento de Planilha: Click lado direito na Aba Base_Códigos > Exibir código e inclua o evento abaixo: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column <> 1 Then Exit Sub Range("F3") = Target.Offset(, 0).Value End Sub Em um módulo: Sub PercorreColunaA() Dim i As Long Dim iUltimaLinha As Long Dim iCol As Long Planilha1.Range("F3").Select iUltimaLinha = Planilha1.Cells(Rows.Count, "A").End(xlUp).Row iCol = 1 'Informe a coluna que será verificada, ou seja, a coluna A For i = 3 To iUltimaLinha If Cells(i, iCol) <> "" Then Cells(i, iCol).Select 'Aqui Sua macro End If Next i Planilha1.Range("F3").Select MsgBox "Filtro finalizado", vbInformation, "© Muca Sistemas - 2020" End Sub

Veja se é isso! ... Planilha_de_Vendas_OUT_19_a_SET_20_(JCB).xlsx

Vai pra última célula preenchida: Sub Ultima() Dim lig As Long Lin = 1 'primeira linha a ser verificada Do While Not IsEmpty(Range("A" & Lin)) Lin = Lin + 1 Loop Range("A" & Lin - 1).Select End Sub

Veja se o anexo lhe ajuda. você pode aproveitar a ideia e adaptar às suas necessidades... AtualizarAbas.rar

Tente assim: =SE(R5="";I5;"")

Desculpe a ignorância, mas "não estou entendendo nada"...

Tente assim: For i = 2 To UltimaLinha If Planilha1.Cells(i, 3) = Planilha1.Cells(i, 4) And Planilha1.Cells(i, 7) = "" Then Planilha1.Cells(i, 7) = Planilha1.Cells(i, 3) ElseIf Planilha1.Cells(i, 3) = 0 And Planilha1.Cells(i, 7) = "" Then Planilha1.Cells(i, 7) = Planilha1.Cells(i, 4) ElseIf Planilha1.Cells(i, 4) = 0 And Planilha1.Cells(i, 7) = "" Then Planilha1.Cells(i, 7) = Planilha1.Cells(i, 3) ElseIf Planilha1.Cells(i, 3) <> Planilha1.Cells(i, 4) And Planilha1.Cells(i, 3) <> 0 And Planilha1.Cells(i, 4) <> 0 And Planilha1.Cells(i, 7) = "" Then Planilha1.Cells(i, 7) = Planilha1.Cells(i, 3) Planilha1.Cells(i + 1, 7) = Planilha1.Cells(i, 4) Lin = Lin + 1 End If Next

Se a célula R5 for maior que zero, então, a célula S5 fica em branco, caso contrário, a célula S5 fica com o valor que estiver em I5. =SE(R5>0;"";I5) Se a célula T5 for maior que zero, então, a célula U5 fica em branco, caso contrário, a célula U5 fica com o valor que estiver em K5. =SE(T5>0;"";K5) Se a célula V5 for maior que zero, então, a célula W5 fica em branco, caso contrário, a célula W5 fica com o valor que estiver em M5. =SE(V5>0;"";M5) Se a célula X5 for maior que zero, então, a célula Y5 fica em branco, caso contrário, a célula Y5 fica com o valor que estiver em O5. =SE(X5>0;"";O5) Na célula Z5 até à célula Z44 some as células com valores. =CONT.SE(R5:Y5;">0")

Veja se o anexo ajuda... PreencheColuna.rar

A macro abaixo salva com os nomes das "Abas". Você pode ajustar para sua planilha... Sub Gerar_PDF() Dim sht As Worksheet 'Percorre todas as planilhas do arquivo For Each sht In ThisWorkbook.Sheets sht.PageSetup.PrintTitleRows = "$1:$1" 'Repete a linha de cabeçalho em cada página 'Gera o PDF sht.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=ThisWorkbook.Path & "\" & sht.Name, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=True, _ OpenAfterPublish:=False sht.PageSetup.PrintTitleRows = "" 'Retorna ao valor padrão Next sht MsgBox "Arquivos gerados com sucesso!!!", vbInformation, "Geração de arquivos PDF" End Sub

Veja se o anexo ajuda. E-mail.rar

Sub Teste() Dim P As String, UltimaLinha As String, Lin As String, i As Integer P = Planilha1.Cells(Rows.Count, "A").End(xlUp).Row Planilha1.Range("A2:R" & P) = "" UltimaLinha = Planilha2.Cells(Rows.Count, "A").End(xlUp).Row Lin = 2 For i = 3 To UltimaLinha Planilha1.Cells(Lin, 1) = Planilha2.Cells(i, 2) Planilha1.Cells(Lin, 3) = Planilha2.Cells(i, 14) Planilha1.Cells(Lin, 4) = Planilha2.Cells(i, 22) Planilha1.Cells(Lin, 6) = Planilha2.Cells(i, 14) Planilha1.Cells(Lin, 7) = Planilha2.Cells(i, 21) Planilha1.Cells(Lin, 8) = Planilha2.Cells(i, 14) Planilha1.Cells(Lin, 9) = Planilha2.Cells(i, 108) Planilha1.Cells(Lin, 12) = Planilha2.Cells(i, 19) Planilha1.Cells(Lin, 17) = Planilha2.Cells(i, 23) Planilha1.Cells(Lin, 24) = Planilha2.Cells(i, 17) Planilha1.Cells(Lin, 25) = Planilha2.Cells(i, 18) Planilha1.Cells(Lin, 18) = Planilha2.Cells(i, 106) Lin = Lin + 1 Next MsgBox "Filtro finalizado" End Sub

crownics, talvez o exemplo em anexo lhe ajude a adaptar às suas necessidades... Pasta1.rar

Tente assim: ‘NO MÓDULO 1 Private TextoDigitado As String Sub pesquisanome() TextoDigitado = frmPesquisa.busca_por_produto.Text Range("A1").Select Dim ws As Worksheet Dim Linha As Integer Dim linhalistbox As Integer Dim TextoCelula As String Set ws = ThisWorkbook.Worksheets("Plan1") Linha = 2 linhalistbox = 0 frmPesquisa.lbDados.Clear With ws While .Cells(Linha, 2).Value <> Empty TextoCelula = .Cells(Linha, 2).Value If UCase(Left(TextoCelula, Len(TextoDigitado))) = UCase(TextoDigitado) Then With frmPesquisa.lbDados .AddItem .List(linhalistbox, 0) = Sheets("Plan1").Cells(Linha, 1) .List(linhalistbox, 1) = Sheets("Plan1").Cells(Linha, 2) .List(linhalistbox, 2) = Sheets("Plan1").Cells(Linha, 3) linhalistbox = linhalistbox + 1 End With End If Linha = Linha + 1 Wend End With End Sub ‘NA TEXTBOX Private Sub busca_por_produto_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) pesquisanome End Sub

Veja se o anexo, com pesquisas por Form, Filtro ou Fórmula, lhe ajuda... FiltrosCombobox.rar