Combine Data into one sheet and create a new column of the source sheet-CodePudding

stack community.

I have found this clear aproach to combine data from all sheets into one.

I just need one improvement. Create a new column after the last one. On each cell of this new column populate with the sheet name of the source data.

Can anyone help me?

Thanks a lot and long life to 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

This code was written by smozgur from vba express fórum.

CodePudding user response：

Like this:

'...
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
'...