VBA：提取列直到空，重复在下一张表

亲爱的堆栈溢出群。

在“Prodcuts.xlmx”文件中，我在工作表“Contract1”的A列中有数千个数值。 相同的文件包含名称为“Contract2”等几个其他类似的工作表。 每个工作表中的行数会发生变化，并且随着时间的推移，可能会在同一个工作表中更改，但它们后面总是跟着空行。 工作表的数量是静态的

我需要从这些工作表收集信息到第二个文件到一个单一的工作表，让我们称之为“产品列表”的格式，其中列A包含重复的工作表名称，列B的数值。

我更喜欢一个提取循环，只是复制这个信息，以避免多个检查的可能的变化。

我不能使用select列复制源，因为在空单元格之后，来了不需要的附加数据集。

总的想法是

获取WS1 Column A的内容，直到空行，复制到“Productlist”列B中

获取WS1 WS名称，复制到“Producist”列A，重复，直到列B没有值（或列B + 1行没有值，以避免额外的一行WS名称）

添加2个空行

重复WS2，直到WSn不存在（或匹配计数）。

Answer 1

我已经回答了类似的其他职位，修改了一下。 为您的情况定制

Sub testing() Dim resultWs As Worksheet Dim ws As Worksheet Dim dataArray As Variant Dim height As Long Dim currentHeight As Long Dim wsName As String Set resultWs = Worksheets("Productlist") For Each ws In Worksheets If InStr(ws.Name, "Contract") Then With ws wsName = .Name height = .Cells(1, 1).End(xlDown).Row 'look til empty row If height > 1048575 Then height = 1 End If ReDim dataArray(1 To height, 1 To 1) dataArray = .Range(.Cells(1, 1), .Cells(height, 1)).Value End With With resultWs currentHeight = .Cells(.Rows.Count, 1).End(xlUp).Row If .Cells(1, 1) = "" Then currentHeight = 0 End If If VarType(dataArray) <> vbDouble Then .Range(.Cells(currentHeight + 1, 1), .Cells(currentHeight + UBound(dataArray, 1), 1)).Value = wsName .Range(.Cells(currentHeight + 1, 2), .Cells(currentHeight + UBound(dataArray, 1), 2)).Value = dataArray Else .Cells(currentHeight + 1, 1).Value = wsName .Cells(currentHeight + 1, 2).Value = dataArray End If End With End If Next ws End Sub