Home » Questions » Computers [ Ask a new question ]

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

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

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





excel vba












ShareShare a link to this question Copy linkCC BY-SA 4.0




Follow
Follow this question to receive notifications











asked 1 min ago





Andre NevaresAndre Nevares

37822 silver badges1515 bronze badges"

Asked by: Guest | Views: 134
Total answers/comments: 0