Bom dia Claudio.. irei testar o teu código..
Eu consegui realizar a importação do arquivo porém foram muitas linhas de código devido aos dados estarem em uma linha apenas.
Tenho certeza se estiver em linhas.. ficará bem mais simples
Código que fiz para importar:
'---------------------------------------------------------------------------------------
' Procedure : ImportaTxt
' Author : Harysohn P. Pina (PILOTO) - Harysohn@hotmail.com
' Fórum : Fórum Máximo Access - http://maximoaccess.forumeiros.com/
' Date : 03/09/2013
' Comentários : Importa arquivo de extrato
'---------------------------------------------------------------------------------------
Function ImportaTxt(banco As String)
Dim Delimitador As String, Delimitador_1 As String
Dim Rs As DAO.Recordset
Dim fnum As Integer
Dim LinhaDoTexto, LinhaDoTextoTemp As String
Dim Posicao As Integer
Dim ArquivoTexto As String
Dim X As Integer
Dim X1 As Integer
Dim nCount As Long
Dim dtDate As Date
Dim dblValor
Dim dblValor1
Dim StrTipo As String
Dim StrSQL As String
Dim StrConta As String
Dim lngNumero
Dim StrDesc As String
Dim TextoTMP As String
Dim CaminhoCopia As String
'---------------------------------------------------
'Carrega a variável com o SQL da tabela tblRetorno
'---------------------------------------------------
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error GoTo TrataErro
Dim NomeProcedimento As String
NomeProcedimento = "ImportaTxt"
'Adiciona o nome do procedimento à função
PegaProcedimento (NomeProcedimento)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
StrSQL = "SELECT * FROM tblimportaextrato"
'---------------------------------------------------
'Carrego o recordset com a SQL
'---------------------------------------------------
Set Rs = CurrentDb.OpenRecordset(StrSQL)
'---------------------------------------------------
'Carrego a variácel com o caminho do arquivo texto
'---------------------------------------------------
ArquivoTexto = StrCaminho
'-------------------------------------------------------------
'Variável para representar o número da linha do arquivo texto
'-------------------------------------------------------------
'nLinha = 0
X = 0
'--------------------------------------------------------------------------------
'Define delimitadores para importação do texto
'--------------------------------------------------------------------------------
Delimitador = ";" 'defina aqui qual o delimitador que não quer importar
Delimitador_1 = """" 'defina aqui qual o delimitador que não quer importar"
'If Delimitador = "" Then Delimitador = " "
'If Delimitador = "" Then Delimitador = vbTab
fnum = FreeFile
'--------------------
'Abre o arquivo texto
'--------------------
Open ArquivoTexto For Input As fnum
'-------------------------
'Realiza loop pelo arquivo
'-------------------------
Do While Not EOF(fnum)
Line Input #fnum, LinhaDoTexto
'Se a variável linha do texto for maior que 0
If Len(LinhaDoTexto) > 0 Then
'Executa laço na linha do texto
Do While Len(LinhaDoTexto) > 0
Volta:
If nCount > 1 Then GoTo Continua
If X = 0 Or X = 1 Or X = 2 Or X = 3 Or X = 4 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X = 5 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Mid$(LinhaDoTexto, 13, 16)
StrConta = Right(TextoTMP, 9)
'MsgBox strConta
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X = 6 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Left$(LinhaDoTexto, Posicao - 1)
dtDate = CDate(Mid(TextoTMP, 8, 2) & "/" & Mid(TextoTMP, 6, 2) & "/" & Mid(TextoTMP, 2, 4))
'MsgBox dtDate
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X = 7 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Left$(LinhaDoTexto, Posicao - 1)
lngNumero = Mid(TextoTMP, 2, 6)
'MsgBox strConta
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X = 8 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Left$(LinhaDoTexto, Posicao - 1)
StrDesc = Mid(TextoTMP, 2, (Len(TextoTMP) - 2))
'StrDesc = Left(TextoTMP, 6)
'MsgBox strConta
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X = 9 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Left$(LinhaDoTexto, Posicao - 1)
If Len(TextoTMP) = 6 Then
dblValor = Mid(TextoTMP, 2, 4)
dblValor = Replace(dblValor, ".", ",")
'MsgBox dblValor
ElseIf Len(TextoTMP) = 8 Then
dblValor = Mid(TextoTMP, 2, 6)
dblValor = Replace(dblValor, ".", ",")
'MsgBox dblValor
ElseIf Len(TextoTMP) = 7 Then
dblValor = Mid(TextoTMP, 2, 5)
dblValor = Replace(dblValor, ".", ",")
'MsgBox dblValor
ElseIf Len(TextoTMP) = 9 Then
dblValor = Mid(TextoTMP, 2, 7)
dblValor = Replace(dblValor, ".", ",")
'MsgBox dblValor
ElseIf Len(TextoTMP) = 10 Then
dblValor = Mid(TextoTMP, 2, 
dblValor = Replace(dblValor, ".", ",")
'MsgBox dblValor
End If
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X = 10 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Left$(LinhaDoTexto, Posicao - 1)
StrTipo = Mid(TextoTMP, 2, 1)
'MsgBox StrTipo
'Linha do texto excluído o texto extraido
'LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
'Adiciona os registros na tabela
Rs.AddNew
Rs!banco = banco
Rs!conta = StrConta
Rs!descricao = StrDesc
Rs!databaixa = dtDate
Rs!Numero = lngNumero
Rs!ValorBaixa = dblValor
Rs!tipo = StrTipo
Rs.Update
nCount = nCount + 1
X1 = 0
End If
X = X + 1
If nCount = 0 Then GoTo Volta
Continua:
If X1 = 0 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Mid$(LinhaDoTexto, 6, 16)
StrConta = Right(TextoTMP, 9)
'MsgBox strConta
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X1 = 1 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Left$(LinhaDoTexto, Posicao - 1)
dtDate = CDate(Mid(TextoTMP, 8, 2) & "/" & Mid(TextoTMP, 6, 2) & "/" & Mid(TextoTMP, 2, 4))
'MsgBox dtDate
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X1 = 2 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Left$(LinhaDoTexto, Posicao - 1)
lngNumero = Mid(TextoTMP, 2, 6)
'MsgBox strConta
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X1 = 3 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Left$(LinhaDoTexto, Posicao - 1)
StrDesc = Mid(TextoTMP, 2, (Len(TextoTMP) - 2))
'StrDesc = Left(TextoTMP, 6)
'MsgBox strConta
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X1 = 4 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
TextoTMP = Left$(LinhaDoTexto, Posicao - 1)
If Len(TextoTMP) = 6 Then
dblValor = Mid(TextoTMP, 2, 4)
dblValor = Replace(dblValor, ".", ",")
'MsgBox dblValor
ElseIf Len(TextoTMP) = 8 Then
dblValor = Mid(TextoTMP, 2, 6)
dblValor = Replace(dblValor, ".", ",")
'MsgBox dblValor
ElseIf Len(TextoTMP) = 7 Then
dblValor = Mid(TextoTMP, 2, 5)
dblValor = Replace(dblValor, ".", ",")
'MsgBox dblValor
ElseIf Len(TextoTMP) = 9 Then
dblValor = Mid(TextoTMP, 2, 7)
dblValor = Replace(dblValor, ".", ",")
'MsgBox dblValor
ElseIf Len(TextoTMP) = 10 Then
dblValor = Mid(TextoTMP, 2,
dblValor = Replace(dblValor, ".", ",")
'MsgBox dblValor
End If
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
ElseIf X1 = 5 Then
'Posição do Delimitador no texto
Posicao = InStr(LinhaDoTexto, Delimitador)
'Texto extraído
If Len(LinhaDoTexto) = 4 Then
StrTipo = Mid(LinhaDoTexto, 1, 1)
Else
TextoTMP = Left$(LinhaDoTexto, Posicao - 1)
StrTipo = Mid(TextoTMP, 2, 1)
'MsgBox StrTipo
End If
'Linha do texto excluído o texto extraido
LinhaDoTexto = Mid$(LinhaDoTexto, Posicao + Len(Delimitador))
'Adiciona os registros na tabela
Rs.AddNew
Rs!banco = banco
Rs!conta = StrConta
Rs!descricao = StrDesc
Rs!databaixa = dtDate
Rs!Numero = lngNumero
Rs!ValorBaixa = dblValor
Rs!tipo = StrTipo
Rs.Update
nCount = nCount + 1
End If
If X1 < 5 Then
X1 = X1 + 1
Else
X1 = 1
End If
'MsgBox LinhaDoTexto
Loop
End If
nCount = nCount + 1
Loop
Finaliza:
Close fnum
'==========================================================================
'Rotina para copiar o arquivo para a pasta importado
'--------------------------------------------------------------------------
Select Case banco
Case "Banco do Brasil"
CaminhoCopia = CurrentProject.Path & "\concilia\importado\BancoDoBrasil\" & StrArquivo1
nCount = nCount - 1
Case "Caixa Econômica"
CaminhoCopia = CurrentProject.Path & "\concilia\importado\Caixa\" & StrArquivo1
nCount = nCount - 1
Case "Siscob"
CaminhoCopia = CurrentProject.Path & "\concilia\importado\Siscob\" & StrArquivo1
nCount = nCount - 1
Case "Itaú"
CaminhoCopia = CurrentProject.Path & "\concilia\importado\Itau\" & StrArquivo1
nCount = nCount - 1
Case "Santander"
Case "Unibanco"
Case "Mercantil do Brasil"
Case "Bradesco"
Case "Banco Rural"
Case "Nossa Caixa"
Case "CitiBank"
Case "BBV Banco"
Case "Bic Banco"
Case "Banco Safra"
Case "Sicredi"
Case "BancoReal"
Case "BCN"
Case "Sudameris"
Case "HSBC"
End Select
'-----------------------
'limpa a caixa de opções
'-----------------------
Me.OpBanco = 0
'-------------
'Executa cópia
'-------------
MsgBox StrCaminho
MsgBox CaminhoCopia
FileCopy StrCaminho, CaminhoCopia
'-------------------------
'Deleta o arquivo original
'-------------------------
Kill StrCaminho
'----------------------
'Gera log de importação
'----------------------
'CurrentDb.Execute "INSERT INTO tblLogRetorno (NomeArquivo,NumeroRegistros,CpData) Values (" _
& """" & StrArquivo & """,""" & nCount & """, #" & Format(Date, "mm/dd/yyyy") & "#)"
'----------------------------------------
'Executa atualização nas ListBox's e Form
'---------------------------------------
Me.lstExtrato.Requery
Me.Requery
'------------------------------------------------
'Mesagem de operação realizada
'------------------------------------------------
MsgBox "Foram importados " & Format$(nCount + 1) & " Registro(s)", vbInformation, "IMPORTAÇAO EFETUADA"
Exit Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Tratamento de Erros
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Exit_TrataErro:
DoCmd.Hourglass False
DoCmd.Echo True
Exit Function
TrataErro:
Select Case Err.Number
Case 5
GoTo Finaliza
Case Else
DoCmd.Hourglass False
DoCmd.Echo True
'Chama a função global de tratamento de erros
GlobalErrHandler (Me.Name)
End Select
End Function
Obrigado
Início
![[Resolvido]Editar arquivo .txt através do VBA Empty](https://2img.net/i/empty.gif)
Convidado 22/8/2013, 20:43
