如何在同一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. 每4行(标题和数据(写入一个单独的制表符分隔的.txt文件
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"的单元格。

然后，它插入一行一行，这样所有集合都用一个空行分隔。

由于这些区域用空行分隔，因此可以将它们设置为范围区域，因此我们可以循环浏览每个范围区域，将其复制到工作表2中，复制工作表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:UsersDaveSkyDriveDocumentsTestTxtFiles"    '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