Question

提前道歉，因为我确信这是一个简单的问题，并且有很多类似的答案，但我无法将它们用于工作解决方案。

我的情况是我有一个包含28个标签的Excel文件。每张表格的数据格式完全相同，范围为A1：N10000。请注意，每个选项卡中的某些单元格是空白的。这适用于每个选项卡。我想将所有28个标签合并为一个新的图纸组合。

我一直在尝试利用这个宏：

Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub

显然我遇到了运行此问题的问题，结果数据只粘贴了一些值，而不是预期的~280,000行（28个标签，每个10k行）。我怀疑其中一个原因是因为选项卡中有空白单元格，所以这个宏不会像我想要的那样读取数据。如何修改它只是为了复制每个选项卡中的A1：N10000并将每个选项卡粘贴到组合选项卡？另外，我是否会尝试填充280,000行的工作表？

谢谢！大卫

Answer 1

如果您怀疑有空白单元格，

CurrentRegion将无法复制您想要的所有内容。此外，最好避免使用Select - 因为你真的不需要在复制之前选择单元格 - 而On Error Resume Next - 这根本不处理错误，它会忽略它们。

Option Explicit

Sub Combine()
    Dim i As Integer
    Dim combinedWs As Worksheet, ws As Worksheet
    Dim copyRng As Range
    Dim lastRow As Long

    ' Add combined worksheet and populate headers
    Set combinedWs = Worksheets.Add(Before:=Sheets(1))
    combinedWs.Name = "Combined"
    Sheets(2).Rows(1).Copy combinedWs.Rows(1)

    ' Loop through rest of Sheets
    For i = 2 To Sheets.Count
        Set ws = Sheets(i)
        With ws
            lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            Set copyRng = Range(.Cells(2, 1), .Cells(lastRow, "N"))
            copyRng.Copy combinedWs.Cells(.Rows.Count, 1).End(xlUp).Offset(1)
        End With
    Next i
End Sub

如果要复制特定的硬编码范围，请替换With ws... End With中的代码。

Set copyRng = Range(.Cells(2, 1), .Cells(10000, 14))
copyRng.Copy combinedWs.Cells(2, 1).Offset((i-2)*copyRng.Rows.Count)

最后一行有点黑客攻击：对于i的每次迭代，你都会偏移copyRng中的行数。您从combinedWs.Cells(2, 1)或A2开始。在第一次迭代中，i - 2 = 0，因此没有偏移量。在后续迭代中，您偏移9999,19998，依此类推。

Answer 2

您可以尝试以下代码：

Sub Combine()
    Dim cmbSheet, ws As Worksheet
    Dim tmpIndex As Double
    Set cmbSheet = ThisWorkbook.Worksheets.Add
    cmbSheet.Name = "Combined"
    tmpIndex = 0
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Combined" Then
            If tmpIndex = 0 Then
                cmbSheet.Cells(1, 1) = "Sheet Name"
                ws.Range("A1:N1").Copy Destination:=cmbSheet.Cells(1, 2)
            End If
            ws.Range("A2:N10000").Copy Destination:=cmbSheet.Cells((tmpIndex * 10000) + 2 - tmpIndex, 2)
            cmbSheet.Cells((tmpIndex * 10000) + 2, 1).Value = ws.Name
            tmpIndex = tmpIndex + 1
        End If
    Next ws
End Sub

使用固定范围合并Excel中的多个选项卡

2 个答案: