efetuei uma planilha em vba excel, porem em uma determinada textbox, estou tendo dor de cabeça,
fiz uma tabela que busca de valores e insere de valores.
Na tabela fde inserção de valores, tudo, ok
efetuei a formula com comando Cdate(textde) - quando preenche a mesma ela inserre corretamente em formato de datas porem,
na busca de valores quando a celula na estão preenchida ele nãos tras nada nesta txtDE, e quando eu efetuo a alteração ele da erro,
porque na opção "Cdade" tem que esdta preenchida com alguma coisa...
consegume me ajudar?
' este faz a busca de valores:
Private Sub txtLocaliza_AfterUpdate()
Dim intervalo As Range
Dim texto As String
Dim codigo As Integer
Dim pequisa
Dim mensagem
codigo = txtLocaliza.Value
'Sheets("Clientes").Select
Set intervalo = Sheets("Clientes").Range("A:Y")
'Define a Range de Pesquisa
Set currentFind = Worksheets("Clientes").Range("A:A").Find(frmCadastroStudents.lblCod, , _
Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, _
Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
Boa tarde,
tenho um problema com VBA, que gostaria que me ajudassem a resolver, pretendo com recurso a código em VBA agregar os dados de forma a que eles sejam somados.
Em baixo, existe uma imagem , com o exemplo do pretendido. A esquerda a tabela que possui os dados de forma massiva e a direita o pretendido.
Será que alguém me pode auxiliar a resolver isto!
Obrigado.
Sou estudante de Programação e nunca tinha usado VBA e tenho de entregar um trabalho, mas nunca tive formação nesta linguagem, e estou a ter problemas no programa na parte de Pesquisar registros com filtros, já tentei ao máximo fazer seguindo tutoriais na internet, até que uma pessoua me ajudou e mandou-me codia e disse para fazer um passos só que eu nao sei seguir esses passos.
Fico muito agradecido se alguém me conseguir ajudar.
O que a pessoa me indicou:
" Para testar o código coloque um filtro na planilha Dados no range A1:L1 e crie uma planilha com o nome de Auxiliar. Cole o código no formulário Pesquisar. "
Option Explicit
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then Call Filtro(TextBox1.Text, ComboBox1.Text)
End Sub
Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then Call Filtro(TextBox2.Text, ComboBox2.Text)
End Sub
Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then Call Filtro(TextBox3.Text, ComboBox3.Text)
End Sub
Private Sub UserForm_Initialize()
ComboBox1.RowSource = "Relatório!A1:A12"
ComboBox2.RowSource = "Relatório!A1:A12"
ComboBox3.RowSource = "Relatório!A1:A12"
End Sub
Sub Filtro(ByVal Pesquisa As String, Campo As String)
Dim Coluna As Integer
Dim Area As Range
Set Area = ThisWorkbook.Sheets("Dados").[A1:L1]
Coluna = WorksheetFunction.Match(Campo, Area, 0)
If Pesquisa <> "" Then
If IsNumeric(Pesquisa) = False Then Pesquisa = "*" & Pesquisa & "*"
Call Area.AutoFilter(Field:=Coluna, Criteria1:=Pesquisa)
Call CopiaTabela
Call PreencheListBox
End If
End Sub
Sub CopiaTabela()
ThisWorkbook.Sheets("Auxiliar").[A:L].Clear
ThisWorkbook.Sheets("Dados").[A1].CurrentRegion.Copy
ThisWorkbook.Sheets("Auxiliar").[A1].PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
Sub PreencheListBox()
Dim Area As Range
Set Area = ThisWorkbook.Sheets("Auxiliar").[A1].CurrentRegion
ListBox1.ColumnCount = Area.Columns.Count
ListBox1.ColumnHeads = True
ListBox1.RowSource = "Auxiliar!" & Area.Offset(1).Address
End Sub
Link do Programa:
https://drive.google.com/file/d/1ucJVL5Ijg0IcDqaFzoJi8aiMPb0NCbjI/view?usp=sharing
Bom dia a todos. Adaptei um código para renomear vários arquivo com vba, que realiza a seguinte função:
1) Eu seleiono a pasta,
2) O VBA abre o PDF (Nota fiscal) , extrai a informação do texto e com a razão social fecha o pdf e renomeia ele com o nome extraido.
O problema é que após renomear o primeiro arquivo corretamente a execução do código trava, e é necessário finalizar o processo.
Segue abaixo o código.
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Public Function ListaArquivos(ByVal Caminho As String) As String()
'Atenção: Faça referência à biblioteca Micrsoft Scripting Runtime
Dim FSO As New FileSystemObject
Dim result() As String
Dim Pasta As Folder
Dim Arquivo As File
Dim Indice As Long
ReDim result(0) As String
If FSO.FolderExists(Caminho) Then
Set Pasta = FSO.GetFolder(Caminho)
For Each Arquivo In Pasta.Files
Indice = IIf(result(0) = "", 0, Indice + 1)
ReDim Preserve result(Indice) As String
result(Indice) = Arquivo.Name
Next
End If
ListaArquivos = result
ErrHandler:
Set FSO = Nothing
Set Pasta = Nothing
Set Arquivo = Nothing
End Function
Private Sub selecionar_pasta()
Dim box As Folder
Dim arquivos() As String
Dim lCtr As Long
Dim AdobeApp As String
Dim StartAdobe
Dim Arquivo As String
Dim NomeAntigo As String
Dim NomeNovo As String
On Error Resume Next
linha = 1
ultima_linha = Sheets("teste").Cells(Rows.Count, 1).End(xlUp).Row
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Buscar pasta"
.InitialFileName = ThisWorkbook.Path
.Show
.AllowMultiSelect = False
Pasta = .SelectedItems(1)
End With
TextBox1 = box
arquivos = ListaArquivos(Pasta)
Sleep 1000
For lCtr = 0 To UBound(arquivos)
Debug.Print arquivos(lCtr)
'Inserir código aqui'
'Cells(linha, 1).Value = arquivos(lCtr)
'linha = (linha + 1)
'Sleep 500
pdf = arquivos(lCtr)
AdobeApp = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
Sleep 2000
For Each pdf In Pasta
Adobefile = Pasta & "\" & pdf
StartAdobe = Shell("" & AdobeApp & " " & """" & Adobefile & """" & "", 1)
Sleep 2000
Application.SendKeys ("^a")
Application.SendKeys ("^c")
Sleep 2000
Dim KillPdf As String
KillPdf = "TASKKILL /F /IM AcroRd32.exe"
Shell KillPdf, vbHide
AppActivate Application.Caption
Sheets("teste").Range("A1").Activate
SendKeys ("^v")
DoEvents
Dim Razao As String
Razao = Sheets("teste").Range("A17").Value
pontos = InStr(1, Razao, ":")
qtdeLetras = Len(Razao)
Nome = Right(Razao, qtdeLetras - pontos)
Sheets("teste").Range("C1").Value = Nome
Do While Not IsEmpty(Range("C1"))
NomeAntigo = Pasta & "\" & pdf
NomeNovo = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"
Sheets("teste").Range("C2").Value = Adobefile
Sheets("teste").Range("C3").Value = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"
Name NomeAntigo As NomeNovo
' DoEvents
Loop
' MsgBox "Nomes dos arquivos alterados!", vbOKOnly, "Processo Concluído"
Next
Next
' MsgBox ("Arquivos Encontrados = ") & (linha - 1)
End Sub
Já tentei de tudo, e não consegui resolver esse problema, se eu remover o Do while, ele executa normalmente, porem não renomeia os arquivos. Seu eu faço esse laço, ele renomeia só o primeiro e trava geral.
Olá! Estou com problema referente a exportação de gráficos do Excel via VBA para apresentação do PowerPoint. A maneira que encontrei, inclusive em várias fontes é de exportar vários gráficos de uma vez ou uma ,em uma nova apresentação. O que estou precisando é de exportar os gráficos do Excel em um arquivo do PowerPoint existente, em slides e locais específicos das apresentações. Se alguém tiver alguma ideia de como fazer seria de muita ajuda.
Tenho um programa desenvolvido em VBA para Autocad, o mesmo tem duas linhas de programação que estão dando o seguinte erro:
as linhas que estão dando erro são as seguintes
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Acredito que tenha alguma coisa a ver do fato do sistema instalado ser 64 bits, algum tem alguma solução para o caso.
Ola amigos é minha primeira vez no forum,
Estou com o seguinte problema:
efetuei uma planilha em vba excel, porem em uma determinada textbox, estou tendo dor de cabeça,
fiz uma tabela que busca de valores e insere de valores.
Na tabela fde inserção de valores, tudo, ok
efetuei a formula com comando Cdate(textde) - quando preenche a mesma ela inserre corretamente em formato de datas porem,
na busca de valores quando a celula na estão preenchida ele nãos tras nada nesta txtDE, e quando eu efetuo a alteração ele da erro,
porque na opção "Cdade" tem que esdta preenchida com alguma coisa...
consegume me ajudar?
' este faz a busca de valores:
Private Sub txtLocaliza_AfterUpdate()
Dim intervalo As Range
Dim texto As String
Dim codigo As Integer
Dim pequisa
Dim mensagem
codigo = txtLocaliza.Value
'Sheets("Clientes").Select
Set intervalo = Sheets("Clientes").Range("A:Y")
On Error GoTo trataErro
pesquisa = Application.WorksheetFunction.VLookup(codigo, intervalo, 2, False)
pesq1 = Application.WorksheetFunction.VLookup(codigo, intervalo, 3, False)
pesq2 = Application.WorksheetFunction.VLookup(codigo, intervalo, 4, False)
pesq3 = Application.WorksheetFunction.VLookup(codigo, intervalo, 5, False)
pesq4 = Application.WorksheetFunction.VLookup(codigo, intervalo, 6, False)
pesq5 = Application.WorksheetFunction.VLookup(codigo, intervalo, 7, False)
pesq6 = Application.WorksheetFunction.VLookup(codigo, intervalo, 8, False)
pesq7 = Application.WorksheetFunction.VLookup(codigo, intervalo, 9, False)
pesq8 = Application.WorksheetFunction.VLookup(codigo, intervalo, 10, False)
pesq9 = Application.WorksheetFunction.VLookup(codigo, intervalo, 11, False)
pesq10 = Application.WorksheetFunction.VLookup(codigo, intervalo, 12, False)
pesq11 = Application.WorksheetFunction.VLookup(codigo, intervalo, 13, False)
pesq12 = Application.WorksheetFunction.VLookup(codigo, intervalo, 14, False)
pesq13 = Application.WorksheetFunction.VLookup(codigo, intervalo, 15, False)
pesq14 = Application.WorksheetFunction.VLookup(codigo, intervalo, 16, False)
pesq15 = Application.WorksheetFunction.VLookup(codigo, intervalo, 17, False)
pesq16 = Application.WorksheetFunction.VLookup(codigo, intervalo, 18, False)
pesq17 = Application.WorksheetFunction.VLookup(codigo, intervalo, 19, False)
pesq18 = Application.WorksheetFunction.VLookup(codigo, intervalo, 20, False)
pesq19 = Application.WorksheetFunction.VLookup(codigo, intervalo, 21, False)
pesq20 = Application.WorksheetFunction.VLookup(codigo, intervalo, 22, False)
pesq21 = Application.WorksheetFunction.VLookup(codigo, intervalo, 23, False)
pesq22 = Application.WorksheetFunction.VLookup(codigo, intervalo, 24, False)
pesq23 = Application.WorksheetFunction.VLookup(codigo, intervalo, 25, False)
pesq24 = Application.WorksheetFunction.VLookup(codigo, intervalo, 1, False)
lblCod = pesq24
txtAddress = CDate(pesquisa)
txtNumber = pesq1
txtNeighb = pesq2
txtCity = pesq3
cbUF = pesq4
txtDDD1 = Format(CCur(pesq5), "#0.000")
txtPhone1 = Format(CCur(pesq6), "#0.000")
txtDDD2 = Format(CCur(pesq7), "#0.000")
txtPhone2 = Format(CCur(pesq8), "#0.000")
txtEmail = Format(CCur(pesq9), "#0.000")
txtmn = Format(CCur(pesq10), "#0.000")
txtti = Format(CCur(pesq11), "#0.000")
txtal = Format(CCur(pesq12), "#0.000")
txtcomplemento = pesq13
If pesq14 <> "" Then
txtDT = CDate(pesq14)
End If
txtIN = pesq15
txtTR = pesq16
''If pesq17 <> "" Then
txtPeso = Format(CCur(pesq17), "###,##0.000")
''End If
txtPecas = pesq18
''If pesq19 <> "" Then
txtPB = Format(CCur(pesq19), "###,##0.000")
''End If
''If pesq20 <> "" Then
txtPL = Format(CCur(pesq20), "###,##0.000")
''End If
If pesq21 <> "" Then
txtDE = CDate(pesq21)
End If
txtDS = pesq22
txtVT = pesq23
Exit Sub
trataErro:
texto = "Não Localizado"
mensagem = MsgBox(texto, vbOKOnly + vbInformation)
End Sub
'este altera na tabela
Sub lsAlterarStudent()
'Define a Range de Pesquisa
Set currentFind = Worksheets("Clientes").Range("A:A").Find(frmCadastroStudents.lblCod, , _
Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, _
Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
lLinha = currentFind.Row
With frmCadastroStudents
Sheets("Clientes").Cells(lLinha, 2).Value = CDate(.txtAddress)
Sheets("Clientes").Cells(lLinha, 3).Value = .txtNumber
Sheets("Clientes").Cells(lLinha, 4).Value = .txtNeighb
Sheets("Clientes").Cells(lLinha, 5).Value = .txtCity
Sheets("Clientes").Cells(lLinha, 6).Value = .cbUF
Sheets("Clientes").Cells(lLinha, 7).Value = CCur(.txtDDD1)
Sheets("Clientes").Cells(lLinha, 8).Value = CCur(.txtPhone1)
Sheets("Clientes").Cells(lLinha, 9).Value = CCur(.txtDDD2)
Sheets("Clientes").Cells(lLinha, 10).Value = CCur(.txtPhone2)
Sheets("Clientes").Cells(lLinha, 11).Value = CCur(.txtEmail)
Sheets("Clientes").Cells(lLinha, 12).Value = CCur(.txtmn)
Sheets("Clientes").Cells(lLinha, 13).Value = CCur(.txtti)
Sheets("Clientes").Cells(lLinha, 14).Value = CCur(.txtal)
Sheets("Clientes").Cells(lLinha, 15).Value = .txtcomplemento
Sheets("Clientes").Cells(lLinha, 16).Value = CDate(.txtDT)
Sheets("Clientes").Cells(lLinha, 17).Value = .txtIN
Sheets("Clientes").Cells(lLinha, 18).Value = .txtTR
''If txtPeso <> "" Then
Sheets("Clientes").Cells(lLinha, 19).Value = CCur(.txtPeso)
''End If
Sheets("Clientes").Cells(lLinha, 20).Value = .txtPecas
''If txtPB <> "" Then
Sheets("Clientes").Cells(lLinha, 21).Value = CCur(.txtPB)
''End If
''If txtPL <> "" Then
Sheets("Clientes").Cells(lLinha, 22).Value = CCur(.txtPL)
''End If
''If txtDE <> "" Then
Sheets("Clientes").Cells(lLinha, 23).Value = CDate(.txtDE)
''End If
Sheets("Clientes").Cells(lLinha, 24).Value = .txtDS
Sheets("Clientes").Cells(lLinha, 25).Value = .txtVT
End With
End Sub
Compartilhar este post
Link para o post
Compartilhar em outros sites