VBA – Exportar Intervalo para CSV (Arquivo de Texto Delimitado)

Salvar intervalo em arquivo CSV

Solução nº 670 sobre como exportar um intervalo para um arquivo de texto delimitado.

Essa é uma alternativa útil para usar a maneira padrão do Excel de salvar a planilha como um arquivo de texto ou arquivo delimitado CSV, escolhendo “salvar como” quando:

1. Você usa um modelo e deseja exportar apenas os dados, excluindo cabeçalhos e outras coisas diversas

2. Da mesma forma, você pode querer exportar apenas parte de um conjunto de dados

3. Você deseja salvar o arquivo com um delimitador personalizado que pode ser exclusivo para a sua aplicação.

Se você precisar fazer 1, 2 ou 3, uma função como a seguinte pode ajudar. Ela aceita um intervalo para exportar, o local para salvar o arquivo e o delimitador com o qual você deseja separar os dados e, em seguida, salva os dados conforme especificado.

Veja como chamar a função ExportarRange:

Sub ChamarExportar()

  'ExportarRange(range,where,delimiter)
  Call ExportarRange(Planilha1.Range("A1:C20"), "C:\teste\mark.txt", ",")

End Sub

Primeiro você informa à função o intervalo que deseja exportar, depois para onde exportá-lo e, em seguida, o delimitador a ser usado. Você também precisará da função ExportarRange, e aqui está ela:

Function ExportarRange(WhatRange As Range, _
         Where As String, Delimiter As String) As String

  Dim HoldRow As Long    'teste para nova variável de linha
  HoldRow = WhatRange.Row

  Dim c As Range

  'loop através da variável range
  For Each c In WhatRange
    If HoldRow <> c.Row Then
      'adicionar quebra de linha e remover o delimitador extra
      ExportarRange = Left(ExportarRange, Len(ExportarRange) - 1) _
                          & vbCrLf & c.Text & Delimiter
        HoldRow = c.Row
    Else
        ExportarRange = ExportarRange & c.Text & Delimiter
    End If
Next c

'Aparar delimitador extra
ExportarRange = Left(ExportarRange, Len(ExportarRange) - 1)

'Eliminar o arquivo se ele já existir
If Len(Dir(Where)) > 0 Then
    Kill Where
End If

Open Where For Append As #1    'gravar o novo arquivo
Print #1, ExportarRange
Close #1
End Function