Question

我完全是VBA文盲，所以如果这看起来很琐碎，我深表歉意。我在具有400行和3列的Excel电子表格中有一个简单的数据集。它被分组为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

我想做的是

每4行（标题和数据）块将每个制表符分隔的.txt文件写入
使用组名（例如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并成为新的工作簿，并将其另存为文本文件并关闭它。

请确保更改代码中的文件夹位置，并使用最后的斜杠（）

假设sheet（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

如何在同一Excel电子表格（VBA）中将多个行块写入单独的文件？

2 个答案: