Я новичок в VBA, я делал это вручную. Мне нужно автоматизировать создание отдельных текстовых файлов для каждого значения в столбце A. Я хочу, чтобы текстовые файлы были названы со значением столбца A, причем столбцы BF являются содержимым текстовых файлов,
Например: у меня есть мастер-файл Excel с 20000 строками (и 5 столбцами) с данными примерно так:
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
У меня есть следующий код далеко от ссылок, но он не возвращает все строки для каждого кода поставщика. Он возвращает только одну строку для каждого 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
Изменить: я попытался с помощью другого ресурса и изменил код. увидеть ниже. Теперь он возвращает все строки для каждого кода поставщика. В отличие от предыдущего кода, он не перезаписывает строки в каждом текстовом файле поставщика, а добавляет его. Но проблема с этим результатом заключается в том, что столбцы находятся в отдельной строке. Мне нужно, чтобы все столбцы были разделены табуляцией в одной строке. Посоветуйте, пожалуйста, как мне исправить второй код. Я очень близок к тому, что мне нужно достичь.
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:\Users\9418\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
** Недавнее редактирование:** Я публикую свой ответ здесь.
После дальнейших ссылок в Интернете я, наконец, нашел код ниже, который возвращает все строки на код поставщика в отдельных текстовых файлах, и значения столбцов также находятся в одной строке. Но теперь проблема с этим запросом заключается в том, что после возврата некоторых текстовых файлов, но при наличии большего количества строк для кода поставщика выдается ошибка «Переполнение». Я попытался разделить строки в моем мастер-файле на отдельные файлы Excel. Каждый из файлов имеет около 200-500 строк. Тем не менее это дает мне ошибку для переполнения. Пожалуйста, кто-нибудь может подсказать, что я могу сделать, чтобы исправить эту ошибку.
Вариант Явный
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