excel - VBA:提取列直到为空，在下一张表中重复

Question

亲爱的 Stack Overflow 群。

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

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

我更喜欢一个简单地复制此信息的提取循环，以避免对可能的更改进行多次检查。

我不能使用选择列来复制源，因为在空单元格之后，会出现不需要的额外数据集。

总体思路是

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

获取WS1 WS名称，复制到“Productlist”A列，重复直到B列没有值(或者B列+1行没有值，避免WS名称多出1行)

添加 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