Question

亲爱的Stack Overflow群。

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

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

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

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

总体思路是

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

获取WS1 WS名称，复制到“Produclist”列A，重复直到B列没有值（或者B + 1行没有值，以避免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

VBA：提取列直到空，在下一页中重复

1 个答案: