Как добавить все данные строки в одно и то же имя файла, связанного с одним и тем же файлом из разных строк

Question

Я пытаюсь создать файлы на основе столбца A, и он записывает данные строки в сгенерированные файлы. Этого я могу добиться с помощью приведенного ниже кода.

Проблема: если имя файла появляется много раз, я хочу добавить все данные строки в одно и то же имя файла, связанное с тем же именем файла из разных строк.

На данный момент он выбирает последнюю строку, ассоциирует имя файла в столбце A и генерирует файл.

Как добавить все данные строки в один файл.

My код,

Sub ExportToNotepad()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object

Dim i&, lastRow&
lastRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To lastRow
Set oFile = fso.CreateTextFile("C:\WriteToFile\" & Cells(i, 1) & ".xml")

oFile.WriteLine Cells(i, 2).Value
oFile.Close

Next i
Set fso = Nothing
Set oFile = Nothing

End Sub

Изображение проблемы,

Answer 1

Возможно, что-то вроде этого:

Sub test()
Set rngSource = Range("A1", Range("A" & Rows.Count).End(xlUp))

rngSource.Copy Range("AA1")
Range("AA:AA").RemoveDuplicates Columns:=1, Header:=xlNo
Set rngUnique = Range("AA1", Range("AA" & Rows.Count).End(xlUp))

Set lr = Cells(rngSource.Rows.Count, rngSource.Column)
Set fso = CreateObject("Scripting.FileSystemObject")

For Each cell In rngUnique
n = Application.CountIf(rngSource, cell.Value)
Set c = rngSource.Find(cell.Value, lookat:=xlWhole, after:=lr)

Set oFile = fso.CreateTextFile("C:\WriteToFile\" & cell.Value & ".xml")
For i = 1 To n
oFile.WriteLine c.Offset(0, 1).Value
Set c = rngSource.FindNext(c)
Next i
Next

rngUnique.ClearContents
End Sub

В этом коде используется помощник по столбцу (столбец AA) для уникальных значений, в случае, если другое такое же значение появляется в непоследовательных строках. Убедитесь, что в столбце AA не будет важного текста / значения.

Answer 2

Ваша программа предоставляет только последнюю строку данных для каждого файла, потому что вы создаете каждую строку вместо добавления. Некоторые ссылки fso:
FileSystemObject FileObject TextStreamObject
Это дает пример добавления

Sub ExportToNotepad()
  ' This only appends to existing files
  Const ForAppending = 8 ' if needed
  Dim fso As Object ' FileSystemObject
  Dim tso As Object ' TextStreamObject
  Dim fileo As Object ' FileObject
  Set fso = CreateObject("Scripting.FileSystemObject")
  Dim i&, lastRow&
  lastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To lastRow
    Set fileo = fso.GetFile("C:\WriteToFile\" & Cells(i, 1) & ".xml")
    Set tso = fileo.OpenAsTextStream(ForAppending)
    tso.WriteLine Cells(i, 2).Value
    tso.Close
  Next i
End Sub