Question

我试图将所有数据合并到一个工作表中，但是在出现特别严重的错误之前，我遇到了“溢出”错误……当然，有一种更好的书写方式来避免这个问题！

Sub collateSheets()

Dim ws As Worksheet
Dim src As Worksheet
Dim LR As Integer
Dim LR2 As Integer

Set ws = Sheets.Add
With ws
    .Name = "Collated Data"
    .Range("1:1").Value = Sheets(2).Range("1:1").Value
End With
For i = 1 To Sheets.Count
    Sheets(i).Activate
    LR = ws.Cells(Rows.Count, 1).End(xlUp).Row
    LR2 = Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
    If LR2 <> 1 Then
        For j = 2 To LR2
            LRinput = LR - 1 + j
            ws.Rows(LRinput).Value = Sheets(i).Rows(j).Value
        Next j
    End If
    LR = vbNull
    LR2 = vbNull
Next i

End Sub

Answer 1

您还在循环访问新的“整理数据”工作表

将其放置为第一张纸，然后从第二张纸上钻出

此外，您可以避免遍历行并将其值复制/粘贴一次。

最后遍历Worksheets集合，并避免任何可能的图表工作表：

Sub collateSheets()
    Dim ws As Worksheet
    Dim src As Worksheet
    Dim LR As Long, LR2 As Long
    Dim i As Long

    Set ws = Worksheets.Add(before:=Sheets(1)) ' place new sheet in first position
    With ws
        .Name = "Collated Data"
        .Range("1:1").value = Sheets(2).Range("1:1").value
    End With
    For i = 2 To Worksheets.Count ' loop from 2nd sheet on (thus avoiding "Collated Data")
        LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        LR2 = Sheets(i).Cells(Sheets(i).Rows.Count, 1).End(xlUp).Row
        If LR2 <> 1 Then ws.Rows(LR + 1).Resize(LR2 - 1).value = Sheets(i).Rows("2:" & LR2).value
    Next
End Sub

Answer 2

我的代码创建了一个名为“输出”的新工作表，并将所有数据导入其中。

Option Explicit

    Sub test()

        Dim ws As Worksheet
        Dim wsNew As Worksheet
        Dim Lrow As Long
        Dim Excist As Boolean
        Dim SheetName As String

        SheetName = "Output"

        Excist = False

        For Each ws In ThisWorkbook.Sheets
            If ws.Name = "Output" Then
                Excist = True
                Set wsNew = ws
            End If
        Next

        If Excist = False Then
            Set wsNew = ThisWorkbook.Sheets.Add(After:= _
                ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            wsNew.Name = SheetName
        End If

        For Each ws In ThisWorkbook.Sheets
            If ws.Name <> "Output" Then
                ws.UsedRange.Copy

                Lrow = wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Row

                wsNew.Range("A" & Lrow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
            End If
        Next

    End Sub

工作表整理溢出问题

2 个答案: