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

Posted 2023-02-19

【中文标题】VBA：提取列直到为空，在下一张表中重复

【英文标题】：VBA: Extract column until empty, repeat in next sheet

【发布时间】：2012-10-27 08:42:42

【问题描述】：

亲爱的 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 不存在（或匹配计数）。

【问题讨论】：

我错误地使用行计数器并检查是否已将某些内容添加到“Contract1”中，然后意识到我必须反检查是否已删除某些内容，并且之后我无法维护格式结构使用不同的工作表对循环进行多次迭代，而无需过多的工作。引用另一个文件时，我完全超出了我的能力范围，而且我不知道如何遍历不同的工作表。

【参考方案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