Eu sou novo no VBA, tenho feito isso manualmente. Preciso automatizar
na criação de arquivos de texto separados para cada valor na coluna A. Eu quero que os arquivos de texto sejam nomeados com o valor da coluna A, com colunas B-F sendo o conteúdo dos arquivos de texto,
Por exemplo:
Eu tenho um arquivo excel mestre com 20000 de linhas (e 5 colunas) com dados algo como abaixo:
VendorCode | ItemCode | Price1 | Price2 | Price3
____________________________________________________
033204 | svk3409 | 23.2 | 23.3 | 23.4
_____________________________________________________
033204 | svk5619 | 24.2 | 24.3 | 24.4
_____________________________________________________
033204 | cli7890 | 34.2 | 34.3 | 34.4
_____________________________________________________
023272 | svk3413 | 18.9 | 18.2 | 18.3
_____________________________________________________
023272 | svk4567 | 90.2 |90.3 | 90.4
Eu tenho o seguinte código longe de referências, mas ele não retorna todas as linhas para o código de cada fornecedor. Ele retorna apenas uma linha para cada vendorcode.txt.
Sub SaveRangeToCsvFiles()
Dim FileName As String
Dim Ws As Worksheet
Dim rngDB As Range
Dim r As Long, c As Long
Dim pathOut As String
Dim i As Long
pathOut = ThisWorkbook.Path & "\" '<~~ set your path: C:\temp\
Set Ws = ActiveSheet 'Sheets("AllData")
With Ws
r = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'c = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
For i = 2 To r
Set rngDB = .Range("a" & i).Resize(1, 6)
FileName = .Range("a" & i).Offset(, 4)
TransToCSV pathOut & FileName & ".txt", rngDB
Next i
End With
MsgBox ("Files Saved Successfully")
End Sub
Sub TransToCSV(myfile As String, rng As Range)
Dim vDB, vR() As String, vTxt()
Dim i As Long, n As Long, j As Integer
Dim objStream
Dim strTxt As String
Set objStream = CreateObject("ADODB.Stream")
vDB = rng
For i = 1 To UBound(vDB, 1)
n = n + 1
ReDim vR(1 To UBound(vDB, 2))
For j = 1 To UBound(vDB, 2)
vR(j) = vDB(i, j)
Next j
ReDim Preserve vTxt(1 To n)
vTxt(n) = Join(vR, vbTab)
Next i
strTxt = Join(vTxt, vbCrLf)
With objStream
'.Charset = "utf-8"
.Open
.WriteText strTxt
.SaveToFile myfile, 2
.Close
End With
Set objStream = Nothing
End Sub
Editar: Eu tentei com a ajuda de outro recurso e mudei o código. ver abaixo. Agora, ele retorna todas as linhas para cada código de fornecedor. Ao contrário do código anterior, ele não sobrescreve as linhas em cada arquivo de texto do fornecedor, em vez disso o anexa. Mas o problema com esse resultado é que as colunas estão em linha separada. O que eu preciso é ter todas as colunas separadas com delimitado por tabulação na mesma linha. Por favor, informe como posso consertar o segundo código. Estou muito perto do que preciso alcançar.
Sub toFile ()
Dim FilePath As String, CellData As String, LastCol As Long, LastRow As Long
Dim Filenum As Integer, loc As String
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Application.DefaultFilePath = "C:\Users18\Desktop\Work Files"
'loc = Application.DefaultFilePath
For i = 1 To LastRow
FilePath = Application.DefaultFilePath & "\" & Trim(ActiveSheet.Cells(i, 1).Value) & ".txt"
Filenum = FreeFile
Open FilePath For Append As Filenum
CellData = ""
For j = 2 To LastCol
CellData = Trim(ActiveSheet.Cells(i, j).Value)
Print #Filenum, CellData
Next j
Close #Filenum
Next i
MsgBox ("Done")
End Sub
** Edição recente: ** Estou postando minha própria resposta aqui.
Depois de fazer mais referências na internet, finalmente encontrei o código abaixo que retorna todas as linhas por código de fornecedor em arquivos de texto separados e os valores da coluna também estão na mesma linha. Mas, agora, o problema com esta consulta é que depois de retornar alguns arquivos de texto, mas quando há mais número de linhas para um código de fornecedor, ele dá erro "Over Flow". Eu tentei separar as linhas no meu arquivo mestre em arquivos separados do Excel. Cada um dos arquivos tem 200 a 500 linhas. Ainda assim, isso me dá o erro de excesso de fluxo. Por favor, alguém pode sugerir o que posso fazer para corrigir esse erro.
Option Explicit
Sub CreateFileEachLine ()
Dim myPathTo As String
myPathTo = "\901db1\IT_Canada\Vending Price Updates"
Dim myFileSystemObject As Object
Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
Dim fileOut As Object
Dim myFileName As String
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 2 To lastRow
If Not IsEmpty(Cells(i, 1)) Then
myFileName = Cells(i, 1) & ".txt"
Set fileOut = myFileSystemObject.OpenTextFile(myFileName, 8, True)
fileOut.write Cells(i, 4) & " " & Cells(i, 8) & " " & Cells(i, 8) & " " & Cells(i, 8) & vbNewLine
fileOut.Close
End If
Next
Set myFileSystemObject = Nothing
Set fileOut = Nothing
End Sub