Проблема переполнения сортировки рабочего листа

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

Мой код создает новый лист с именем «Вывод» и импортирует все данные в него.

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

Answer 2

Вы также зацикливаетесь на новом листе «Сопоставленные данные»

поместите его как первый лист и выделите из листа 2 на

также, вы можете избежать итерации по строкам и копировать / вставлять их значения в один кадр

наконец-то просматривайте коллекцию 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