Basole

@ricardo_br realmente no seu PC, não existe esse caminho [\UBR] Experimente este outro vbscript Set dtmConvertedDate = CreateObject("WbemScripting.SWbemDateTime") strComputer = "." Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2") Set oss = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem") For Each os in oss dtmConvertedDate.Value = os.InstallDate dtmInstallDate = dtmConvertedDate.GetVarDate Wscript.Echo "Boot Device: " & os.BootDevice & vbnewline & _ vbnewline & "Build Number: " & os.BuildNumber & _ vbnewline & "Build Type: " & os.BuildType & _ vbnewline & "Caption: " & os.Caption & _ vbnewline & "Code Set: " & os.CodeSet & _ vbnewline & "Country Code: " & os.CountryCode & _ vbnewline & "Debug: " & os.Debug & _ vbnewline & "Encryption Level: " & os.EncryptionLevel & _ vbnewline & "Install Date: " & dtmInstallDate & _ vbnewline & "Licensed Users: " & os.NumberOfLicensedUsers & _ vbnewline & "Organization: " & os.Organization & _ vbnewline & "OS Language: " & os.OSLanguage & _ vbnewline & "OS Product Suite: " & os.OSProductSuite & _ vbnewline & "OS Type: " & os.OSType & _ vbnewline & "Primary: " & os.Primary & _ vbnewline & "Registered User: " & os.RegisteredUser & _ vbnewline & "Serial Number: " & os.SerialNumber & _ vbnewline & "Version: " & os.Version Next * salvar com extensão *.vbs

@ricardo_br pode ser, mas experimente este batch... for /f "tokens=2*" %%a in ('Reg Query "HKLM\Software\Microsoft\Windows NT\CurrentVersion" /v ProductName') do set "ProductName=%%~b" for /f "tokens=2*" %%a in ('Reg Query "HKLM\Software\Microsoft\Windows NT\CurrentVersion" /v CurrentVersion') do set "CurrentVersion=%%~b" for /f "tokens=2*" %%a in ('Reg Query "HKLM\Software\Microsoft\Windows NT\CurrentVersion" /v CurrentBuild') do set "CurrentBuildHex=%%~b" for /f "tokens=2*" %%a in ('Reg Query "HKLM\Software\Microsoft\Windows NT\CurrentVersion" /v UBR') do set "UBRHEX=%%~b" set /a CurrentBuildDec=%CurrentBuildHex% set /a UBRDEC=%UBRHEX% echo %computername% %ProductName% Version: %CurrentVersion%, Build: %CurrentBuildDec%.%UBRDEC%

@ricardo_br pra mim rodou perfeitamente @Erso obrigado, eu ja alterei manualmente o txt anexo e atualizei

@Raquel Coelho no anexo da minha postagem, aproveitei os cálculos que você fez no seu modelo, mas vendo com mais calma, verifiquei que os valores gerados das parcelas e o total, não estão corretos. Fazendo uma simulação... por exemplo de 1 real com juros de 1% e com 5 parcelas, o valor total será de 6 reais. Então fiz um exemplo usando a função PGTO, nativo do Excel, que calcula o pagamento de um empréstimo de acordo com pagamentos constantes e com uma taxa de juros constante. https://support.office.com/client/função-pgto-0214da64-9a63-4996-bc20-214433fa6441?NS=EXCEL&Version=16&AppVer=ZXL160 Que quiser usar minha sugestão, substitua a linha abaixo no botão Button_SimulaParcelaGP do userform: ' // * USO DA FUNÇÃO: '=PGTO((juros/100 ->converte %); nParc; VTCompra)* -1 ->(p/convert vl.positivo) ' // * PMT (em inglês) ' .List(nParcelas - 1, 4) = VBA.Format(Excel.Application.WorksheetFunction.Pmt _ ((Me.Comb_JurosParcelaGP.Value / 100), Me.Comb_NParcelasGP.Value, Me.Text_ValorVendaCompraGP.Value * -1), "currency")

@ricardo_br valeu cara comi bola! Obrigado, já removi do post e atualizei aqui InfoWim.zip

@Erso fiz as adaptações nos códigos que você postou. Veja se é isso (anexo):

@Raquel Coelho o Listbox não tem todos os recursos do Listview, como o cabeçalho, por exemplo e pra dribrar isso, eu inseri mais um componente Listbox para atender o recurso. Quanto a escolha da data das parcelas atualizei a rotina para selecionar a primeira p/ 30 dias, e as demais de acordo com combobox (período) Veja se é isso ! Modelo Simulador_v1.zip

@Roger Prado substitua a linha a baixo, no seu script 'copiar a seleção e local onde vai ser colado Selection.Copy Destination:=Workbooks(iPlan).Worksheets("Planilha3") _ .Range("A" & Cells(Rows.Count, "A").End(xlUp).Offset(1).Row)

@Raquel Coelho infelizmente não consigo pois não tem como testar, o meu Office é 64 bits e o componente Listview não está presente mais nesta versão. Mas não é recomendado utilizar o listview, pois muitas pessoas estão usando o office 64 e não vão conseguir utilizar todos recursos da sua planilha. Se ao invés do listview, puder usar o listbox, posso tentar te ajudar.

@Luciana Goes espero ter entendido. LISTBOX_1.zip

@Helton5antos sim, há outras possibilidades, inserindo criterios definindo os campos que podem carregar os dados no listbox, mas eu prefiro desta forma, definindo na cláusula SQL, quais campos serão selecionados na pesquisa. No caso, com somente o asterisco ( * ), todos campos serão incluidos na pesquisa, mas neste caso vamos definir somente os campos que voce citou. Veja como fica, com as alterações: Sub EstruturaNominal_Preencher_Listbox() ' PESQUISAR DADOS NO BD: Dim rsArray As Variant Dim CampsTbl As String CampsTbl = "Identificação,CodigoCADM,CodigoRG,OrdemIG," & _ "TipoIG,OrdemJCE,CodigoJCE,TipoJCE,OrdemJC,CodigoJC" ConectaBD 'Abrir o BD 'Declarar as instruçoes SQL: SQL = "SELECT " & CampsTbl & " FROM tblEstruturaNominal" Call AbrirTabela 'Validar comando SQL para Abrir Tabela no BD frmEstruturaNominal.lstEstruturaNominal.Clear If Not RS.EOF Then rsArray = RS.GetRows frmEstruturaNominal.lstEstruturaNominal.List = TransposeArray(rsArray) End If DesconectaBD End Sub * Substitua o código acima, no seu projeto, mantendo a função TransposeArray

@H3l70N pelo que entendi voce quer popular os dados de uma tabela do BD access no listbox. Experimente o codigo abaixo: Sub EstruturaNominal_Preencher_Listbox() ' PESQUISAR DADOS NO BD: Dim rsArray As Variant ConectaBD 'Abrir o BD SQL = "SELECT * FROM tblEstruturaNominal" 'Declarar as instruçoes SQL Call AbrirTabela 'Validar comando SQL para Abrir Tabela no BD frmEstruturaNominal.lstEstruturaNominal.Clear If Not RS.EOF Then rsArray = RS.GetRows frmEstruturaNominal.lstEstruturaNominal.List = TransposeArray(rsArray) End If DesconectaBD End Sub Private Function TransposeArray(myarray As Variant) As Variant Dim X As Long Dim Y As Long Dim Xupper As Long Dim Yupper As Long Dim tempArray As Variant Xupper = UBound(myarray, 2) Yupper = UBound(myarray, 1) ReDim tempArray(Xupper, Yupper) For X = 0 To Xupper For Y = 0 To Yupper tempArray(X, Y) = myarray(Y, X) Next Y Next X TransposeArray = tempArray End Function

@pedroch não tem como eu testar, pois não estou no meu PC no momento, mas experimente, a cima da Linha Next s colocar o comando abaixo: Kill SelFiles(s) & ".rtf"

@Martti pelo que entendi voce quer que, ao inserir um novo registro na planilha WS e na coluna K [ TRDPP ], o valor for 2, copiar a linha toda, automaticamente, para a aba TRDPP. Veja se é isso: IMAGE_DATA.zip

@AdolffGustavo bom pelo que entendi, voce quer digitar o cnpj na coluna B, a partir da linha 7 e automaticamente o evento Change chame a rotina que faz a consulta na internet e o resultado da pesquisa apareça na respectiva linha na coluna C&D (celula mesclada) Fiz as alterações conforme escrito acima e acrescentei um botão para que possa desabilitar o evento, caso precise fazer algum tipo de alteração de sem interferencias, no intervalo B7:B72, (conforme imagem abaixo) Verifiquei quando estava fazendo testes, que um cnpj que comece com 01, por exemplo, o resultado foi nulo, pois o Excel não considera 0 (zeros) as esquerda, então pra driblar isto, crescentei a aspas simples ( ' ) ai o resultado foi satisfatório. Consulta_CNPJ.zip

@fradseu eu testei a opção de copiar e colar, o intervalor da aba impressão no corpo do email mas formatação se altera no tamanho. Então deixei tambem a opção de copiar e colar como imagem, ai o tamanho fica proximo do real. Veja se atende: Public Sub sendEmail() Dim thund As String Dim email As String Dim CC As String Dim BCC As String Dim subj As String Dim body As String Dim Attch As String Dim oRngToCopy As Range email = "[email protected]" CC = "[email protected]" BCC = "[email protected]" subj = "Testing" body = "Testing" Attch = "" Set oRngToCopy = ThisWorkbook.Sheets("Impressão").Range("B2:Z52") ' OPÇÃO 1 : COPIAR NO FORMATO DE IMAGEM oRngToCopy.CopyPicture xlScreen, xlBitmap ' OPÇÃO 2 : COPIAR O INTERVALO ' oRngToCopy.Copy thund = "C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe\thunderbird.exe " & _ "-compose " & """" & _ "to='" & email & "'," & _ "cc='" & CC & "'," & _ "bcc='" & BCC & "'," & _ "subject='" & subj & "'," & _ "message='" & Attch & "'," & _ "body='" & body & "'" & """" ' ALTERE * ABAIXO O TEMPO DE ESPERA, SE NECESSARIO: Call Shell(thund, vbNormalFocus) Application.Wait (VBA.Now + VBA.TimeValue("0:00:09")) ' 9 seg.* VBA.SendKeys "^v", True ' cola na janela do corpo do email Application.Wait (VBA.Now + VBA.TimeValue("0:00:03")) ' 3 seg. * VBA.SendKeys "^{ENTER}", True End Sub

@Maykon Albuquerque segue sugestão de simples pesquisa em multi-colunas com formulario PLANILHA NOVA DE CONSULTA - MAYKON.zip

Veja nas alterações se é isso que precisa. Insira o codigo de rastreamento na celula A2 e execute a macro Sub RastreamentoCorreios() Set IE = CreateObject("internetexplorer.application") IE.Visible = False IE.Navigate "https://www2.correios.com.br/sistemas/rastreamento/default.cfm" Do While IE.Busy Or IE.ReadyState <> 4: Loop ' Codigo Rastreamento na A1 With ActiveSheet IE.Document.getElementByID("objetos").innerText = VBA.Trim(.Range("A2").Value2) IE.Document.getElementByID("btnPesq").Click Do While IE.Busy Or IE.ReadyState <> 4: Loop For Each elementoTabela In IE.Document.getElementsByClassName("listEvent sro") .Cells(Cells(Rows.Count, 2).End(xlUp).Offset(1).Row, 2) = _ VBA.Replace(elementoTabela.innerText, VBA.Chr$(10), "") Exit For Next End With IE.Quit End Sub

@Julio Cesar Trombetta veja este link tem essa opção, apenas é necessário adaptar a sua necessidade + Aqui

@josequali eu não consegui detectar nenhuma anomalia, somente com esses dados. O ideal é se puder disponibilizar os arquivos para uma análise mais apurada.]

@paulocezarpicos beleza segue o código com as alterações. Abrx. Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) If ActiveSheet.Name <> "Geral" Then Exit Sub Sheets("Geral").Unprotect "0" Static xLastRng As Range On Error Resume Next On Error Resume Next If Not Application.Intersect(taget, Range("B7:G7,B9:D9,F9:G9,B11:C11," & _ "E11:F11,G11,A14:D14,E14:G14")) Is Nothing Then Application.EnableEvents = False Target.Interior.ColorIndex = 2 xLastRng.Interior.ColorIndex = 36 Set xLastRng = Target Sheets("Geral").Protect "0" Application.EnableEvents = True End If On Error GoTo 0 End Sub

@paulocezarpicos veja se com essas alterações, com o codigo que voce postou na primeira postagem, lhe atende. * Fiz pequenas alterações na rotina que limpa os campos. Orçamento Kit Solar.zip

@paulocezarpicos mas essas celulas (intervalos), estão brancas, então qunado selecionar, não vai perceber a diferença

@paulocezarpicos muito obrigado por suas palavras ! Como eu não estou familarizado com seu negocio é preciso que seja mais especifico. Quais seriam esses campos ou intervalos ?

Veja se é isso: ... Sub procurarValorCopiarLinhaInteira() Dim rng As Range Dim r As Range With Sheets("Planilha2") For Each r In .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row) ' Procura o valor na planilha1, (valor)que está na planilha2 (na Coluna A) Set rng = Sheets("Planilha1").Columns("A").Find(.Range("A" & r.Row).Value, _ LookIn:=xlValues, lookat:=xlWhole) If Not rng Is Nothing Then 'copia a linha inteira e cola na celula respectiva linha da Planilha2 rng.EntireRow.Copy Destination:=.Range("A" & r.Row) End If Next r End With End Sub