Arquivos de texto com VBA - Parte 2

Este post foi originalmente publicado em http://officevbavsto.blogspot.com/2011/04/vba-excel-arquivos-de-texto-parte-ii.html.

Hoje, continuo meu post sobre arquivos de texto e vou explicar como gravar informações no arquivo de texto.

Usarei a seguinte planilha como exemplo:

Vamos ao código:

Sub arquivo_texto()

	'Adicionar referência ao objeto Microsoft Scripting Runtime Dim fso As FileSystemObject

	Dim txt As TextStream
	Dim rng As Range

	Set fso = New FileSystemObjectSet txt = fso.OpenTextFile("D:\meu_arquivo.txt", ForWriting, True)
	
	For Each rng In ThisWorkbook.Worksheets(1).Range("B4").CurrentRegion.Rows
		txt.WriteLine rng.Cells(1, 1)
	Next rng
	
	txt.Close
	Set txt = Nothing
	Set fso = Nothing
	
End Sub 

• ForWriting eu já expliquei anteriormente, mas não faz nada além de sobrescrever quaisquer informações que venham a existir no arquivo.
• True é para o argumento de que caso o arquivo não exista, é criado um novo em branco.
• WriteLine é um método que escreve uma linha no arquivo.

Após a execução deste método, teremos a seguinte informação no arquivo de texto:

Execute o código várias vezes e você verá que ele sempre sobrepõe o arquivo. Como acrescentar novas informações? Utilize o parâmetro ForAppending.

Sub arquivo_texto()

	'Adicionar referência ao objeto Microsoft Scripting Runtime
	
	Dim fso As FileSystemObject
	Dim txt As TextStream
	Dim rng As Range
	Set fso = New FileSystemObject
	Set txt = fso.OpenTextFile("D:\meu_arquivo.txt", ForAppending, True)
	
	For Each rng In ThisWorkbook.Worksheets(1).Range("B4").CurrentRegion.Rows
		txt.WriteLine rng.Cells(1, 1)
	Next rng 
	
	txt.Close
	Set txt = Nothing
	Set fso = Nothing
End Sub 

E para finalizar, um código mais otimizado:

Sub arquivo_texto()

	'Adicionar referência ao objeto Microsoft Scripting Runtime
	
	Dim fso As FileSystemObject
	Dim txt As TextStream
	Dim rng As Range, subRng As Range
	Dim strAux As String
	Set fso = New FileSystemObject
	Set txt = fso.OpenTextFile("D:\meu_arquivo.txt", ForAppending, True)
	
	For Each rng In ThisWorkbook.Worksheets(1).Range("B4").CurrentRegion.Rows
		strAux = ""
		For Each subRng In rng.Cells
			strAux = strAux & subRng.Cells(1, 1) & " | "
		Next subRng
		txt.WriteLine strAux
	Next rng
	
	txt.Close
	Set txt = Nothing
	Set fso = Nothing
	
End Sub 

Créditos

Photo by Dominika Roseclay from Pexels