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