使用第一列中的工作表名称将多个工作表复制到一个工作表中

Question

我需要在一个单独复制多个工作表，并使用此脚本放置第二列（B）中的所有数据。 如何将每张纸的名称放在第一栏（A）中？

Public Sub m()

Dim sh As Worksheet
Dim shStorico As Worksheet
Dim lng As Long
Dim lRiga As Long

Set shStorico = ThisWorkbook.Worksheets("DATI")

With shStorico
    For Each sh In ThisWorkbook.Worksheets
            lRiga = .Range("B" & .Rows.Count).End(xlUp).Row
            ThisWorkbook.Worksheets(sh.Name).Range("A2:E200").Copy
            .Range("B" & lRiga + 1).PasteSpecial

    Next
End With

Application.CutCopyMode = False

Set sh = Nothing
Set shStorico = Nothing

End Sub

实施例

更新

这是有效的解决方案

Public Sub m()
Dim sh As Worksheet
Dim shStorico As Worksheet
Dim lng As Long
Dim lRiga As Long
Dim Rng As Range, Rng2 As Range, rArea As Range
Dim iRow As Long

Set shStorico = ThisWorkbook.Worksheets("DATI")
With shStorico
    For Each sh In ThisWorkbook.Worksheets
        lRiga = .Range("B" & .Rows.Count).End(xlUp).Row
        ThisWorkbook.Worksheets(sh.Name).Range("A2:D2000").Copy
        .Range("B" & lRiga + 1).PasteSpecial
        .Range("A" & lRiga + 1).Value = sh.Name
    Next sh
    iRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    Set Rng = .Range("A2").Resize(iRow - 1)
    On Error Resume Next
    Set Rng2 = Rng.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not Rng2 Is Nothing Then
        For Each rArea In Rng2.Areas
            With rArea
                .Value = .Cells(1).Offset(-1).Value
            End With
        Next rArea
    End If
End With

Application.CutCopyMode = False
Set sh = Nothing
Set shStorico = Nothing
End Sub