Как записать в отдельные файлы несколько блоков строк в одной электронной таблице Excel (VBA)?

Question

Я полный неграмотный VBA, поэтому я прошу прощения, если это кажется тривиальным.У меня есть простой набор данных в электронной таблице Excel, которая имеет 400 строк и 3 столбца.Он сгруппирован в меньшие наборы из 4 строк (1 строка заголовков и 3 строки данных) и выглядит следующим образом:

Set1    A   B
1      2.5  1.25
2      4.2  3.35
3      6.7  5.75
Set2    A   B
1      3.3  1.65
2      4.1  1.1
3      2.2  7.59
Set3    A   B
1      5.4  2.7
2      3.9  3.35
3      6.7  12.42

Что я хотел бы сделать, это

1. записывать в отдельные файлы .txt с разделителями табуляции каждый блок из 4 строк (заголовки и данные)
2. использовать имя группы (например, Set1) в качестве имени выходного файла (например, Set1.txt)

Мое ограниченное понимание заключается в том, что мне нужно

• перебрать строки в диапазоне ячеек
• захватить первую ячейку в виде строки для имени файла
• создать / открыть выходной файл, используя эту строку
• запись в файл блока строк
• продолжить со следующей итерацией цикла

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

Answer 1

Попробуйте

Sub test()
    Dim rngDB As Range, rng As Range
    Dim r As Long, i As Long
    Dim Fn As String, myPath As String

    myPath = ThisWorkbook.Path & "\"
    Set rngDB = Range("a1").CurrentRegion

    r = rngDB.Rows.Count

    With rngDB
        For i = 1 To r Step 4
            Set rng = .Range("a" & i).Resize(4, 3)
            Fn = myPath & .Range("a" & i) & ".txt"
            TransToText rng, Fn
        Next i
    End With
End Sub
Sub TransToText(rng As Range, strFile As String)
    Dim vDB, vR() As String, vTxt()
    Dim i As Long, j As Integer, n As Long
    Dim objStream

    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 strFile, 2
        .Close
    End With
    Set objStream = Nothing

End Sub

Answer 2

Это перебирает столбец A и находит ячейки со словом «Set».

Затем вставляется строка в строку, так что все наборы разделяются пустой строкой.

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

Убедитесь, что изменили расположение папки в коде и указали последнюю косую черту ()

Предположение, что лист (2) пуст, его необходимо проиндексировать, потому что код изменит имя листа.

Sub Select_Set()
    Dim FrstRng As Range
    Dim UnionRng As Range
    Dim c As Range
    Dim sh As Worksheet, ws As Worksheet
    Dim RangeArea As Range
    Dim fLdr As String, fNm As String

    fLdr = "C:\Users\Dave\SkyDrive\Documents\TestTxtFiles\"    'folder location to save text files

    Set sh = ActiveSheet
    Set ws = Sheets(2)
    Application.ScreenUpdating = False

    With sh
        Set FrstRng = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)

        For Each c In FrstRng.Cells
            If InStr(c, "Set") Then
                If Not UnionRng Is Nothing Then
                    Set UnionRng = Union(UnionRng, c)    'adds to the range
                Else
                    Set UnionRng = c
                End If
            End If
        Next c

        UnionRng.EntireRow.Insert

        For Each RangeArea In .Columns("A").SpecialCells(xlCellTypeConstants, 23).Areas
            fNm = RangeArea.Cells(1).Value
            RangeArea.Resize(, 3).Copy ws.Cells(1, 1)
            ws.Name = fNm
            ws.Copy
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs fLdr & fNm & ".txt", xlUnicodeText
            ActiveWorkbook.Close
        Next RangeArea

    End With

End Sub

Вы можете удалить пустые строки

Sub reset()
    Columns("A:A").EntireColumn.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub