將數據合並到一張表中並在源表中創建一個新列

Question

堆棧社區。

我發現這種將所有工作表中的數據合並為一個的清晰方法。

我只需要一項改進。 在最后一列之后創建一個新列。 在這個新列的每個單元格上填充源數據的工作表名稱。

誰能幫我？

非常感謝 Stack Overflow

Sub CopyFromWorksheets()

    Dim wrk As Workbook 'Workbook object
    Dim sht As Worksheet 'Object for handling worksheets in loop
    Dim trg As Worksheet 'Master Worksheet
    Dim rng As Range 'Range object
    Dim colCount As Integer 'O número de colunas
     
    Set wrk = ActiveWorkbook 'Working in active workbook
    
    nome_planilha = "Master"
    
    For Each sht In wrk.Worksheets
        If sht.name = "Master" Then
            MsgBox "Já existe uma planilha chamada de '" & nome_planilha & "'." & vbCrLf & _
            "O código cria uma planilha chamada '" & nome_planilha & "'. Esse nome " & _
            "não pode estar em nenhuma planilha existente.  Não podemos continuar.", vbOKOnly + vbExclamation, "Error"
            Exit Sub
        End If
    Next sht
     
    Application.ScreenUpdating = False
     
    Set trg = wrk.Worksheets.add(After:=wrk.Worksheets(wrk.Worksheets.Count))
    trg.name = "Master"
    
    
    Set sht = wrk.Worksheets(1)
    colCount = sht.Cells(1, 255).End(xlToLeft).Column
    
    With trg.Cells(1, 1).Resize(1, colCount)
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value
        .Font.Bold = True
    End With
     
    For Each sht In wrk.Worksheets
             If sht.name = nome_planilha Then
            Exit For
        End If
         'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
        Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
         'Put data into the Master worksheet
        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
    Next sht
    
    'Ajustar todas as colunas
    trg.Columns.AutoFit
     
    'Temos que reativar a tela
    Application.ScreenUpdating = True
End Sub

此代碼從VBA快遞論壇是書面的smozgur。

Answer 1

像這樣：

'...
For Each sht In wrk.Worksheets
             If sht.name = nome_planilha Then
            Exit For
        End If
         'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
        Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
         'Put data into the Master worksheet
        With trg.Cells(65536, 1).End(xlUp).Offset(1)
            .Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
            .Offset(0, rng.Columns.Count).Resize(rng.Rows.Count).Value = sht.Name
        End With
    Next sht
'...