Vba - quebrar arquivo em parte menores

Disponível somente no TrabalhosFeitos
  • Páginas : 2 (284 palavras )
  • Download(s) : 0
  • Publicado : 4 de novembro de 2012
Ler documento completo
Amostra do texto
Este documento tem como objetivo mostrar como podemos quebrar um arquivo grande em parte menores utilizando o VBA.

Para isso, vá na janela do VBA e no menu "Ferramentas", clique no item"Referências". Procure e marque a checkbox "Microsoft Scripting Runtime", clique em "Ok".

textbox: txtCaminhoCompletoArq
textbox: txtCaminhoCompletoArqMenores
textbox: txtQtde
botão decomando: cmdQuebra

O evento click do botão deve ficar assim:

Private Sub cmdQuebra_Click()
'
' Importa o arquivo txt grande e coloca as partes dele em arquivos diferentes
'

Dim sArq AsString
Dim sDir As String
Dim TextLine As String
Dim MaxLinhas As Long
Dim k As Long

Dim fso As FileSystemObject
Dim fArq As TextStream
Dim fTest As File

If MsgBox("Confirma importaçãodo arquivo txt?", vbQuestion + vbYesNo, "Confirmando") = vbNo Then
Exit Sub
End If

sArq = Me.txtCaminhoCompletoArq
sDir = Me.txtCaminhoCompletoArqMenores

MaxLinhas = txtQtde '''''''''''indTab = 1

Set fso = New FileSystemObject
Set fArq = fso.CreateTextFile(sDir & "\sub" & Format(indTab, "000") & ".txt", True)

Open sArq For Input As #1
' Faz o loop até o fim doarquivo.
Do While Not EOF(1)
' Lê a linha para a variável.
Line Input #1, TextLine
' Imprima na janela Immediate.
'Debug.Print TextLine
' Põe no arquivo de saída
fArq.WriteLine TextLine
k = k +1
If k = MaxLinhas Then 'quebra arquivo com MaxLinhas linhas (mude este valor na caixa de texto se quiser 1000, por exemplo)
indTab = indTab + 1
fArq.Close
Set fArq =fso.CreateTextFile(sDir & "\sub" & Format(indTab, "000") & ".txt", True)
k = 0
End If
Loop
Close #1
fArq.Close

'testa se o último arquivo é vazio
Set fTest = fso.GetFile(sDir & "\sub" & Format(indTab, "000")& ".txt")
If fTest.Size = 0 Then
fTest.Delete
Set fTest = Nothing
End If

Set fArq = Nothing
Set fso = Nothing
MsgBox "Arquivo importado com sucesso!", vbExclamation, "Pronto"
End Sub
tracking img