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.
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.
Boa tarde não estou conseguindo rodar o codigo abaixo:
Const IntervaloSegundos = 5 * 60 ' 5 minutos de intervalo
Sub Iniciar()
Alarme = Now + TimeSerial(0, 0, IntervaloSegundos)
Application.OnTime EarliestTime:=Alarme, procedure:="Macro_Atualizar_Tramite_web", schedule:=True
End Sub
Function Macro_Atualizar_Tramite_web()
On Error GoTo Macro_Atualizar_Tramite_web_Err
DoCmd.SetWarnings False
DoCmd.OpenQuery "CRIAR_TABELA_TRAMITACAO_CONTRATACAO", acViewNormal, acEdit
DoCmd.OpenQuery "CRIAR_TABELA_TRAMITACAO_CONSUMO", acViewNormal, acEdit
Beep
MsgBox "Dados Atualizados!", vbExclamation, "Carga"
Macro_Atualizar_Tramite_web_Exit:
Exit Function
Macro_Atualizar_Tramite_web_Err:
MsgBox Error$
Resume Macro_Atualizar_Tramite_web_Exit
Call Iniciar
End Function
Sub Parar()
On Error Resume Next
Application.OnTime EarliestTime:=Alarme, procedure:="Macro_Atualizar_Tramite_web", schedule:=False
End Sub
Obrigado